read_and_send_mpi.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
MODULE modi_read_and_send_mpi
!
INTERFACE read_and_send_mpi
!
SUBROUTINE read_and_send_mpi_n1d(KWORK,KWORK2,KMASK,KPIO,KDX)
!
INTEGER, DIMENSION(:), INTENT(IN) :: KWORK
INTEGER, DIMENSION(:), INTENT(OUT) :: KWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
END SUBROUTINE read_and_send_mpi_n1d
!
SUBROUTINE read_and_send_mpi_n2d(KWORK,KWORK2,KMASK)
!
INTEGER, DIMENSION(:,:), INTENT(IN) :: KWORK
INTEGER, DIMENSION(:,:), INTENT(OUT) :: KWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
END SUBROUTINE read_and_send_mpi_n2d
!
SUBROUTINE read_and_send_mpi_n3d(KWORK,KWORK2,KMASK,KPIO,KDX)
!
INTEGER, DIMENSION(:,:,:), INTENT(IN) :: KWORK
INTEGER, DIMENSION(:,:,:), INTENT(OUT) :: KWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
END SUBROUTINE read_and_send_mpi_n3d
!
SUBROUTINE read_and_send_mpi_x1d(PWORK,PWORK2,KMASK,KPIO,KDX)
!
REAL, DIMENSION(:), INTENT(IN) :: PWORK
REAL, DIMENSION(:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
END SUBROUTINE read_and_send_mpi_x1d
!
SUBROUTINE read_and_send_mpi_x2d(PWORK,PWORK2,KMASK,KPIO,KDX)
!
REAL, DIMENSION(:,:), INTENT(IN) :: PWORK
REAL, DIMENSION(:,:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
END SUBROUTINE read_and_send_mpi_x2d
!
SUBROUTINE read_and_send_mpi_x3d(PWORK,PWORK2,KMASK,KPIO,KDX)
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PWORK
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
END SUBROUTINE read_and_send_mpi_x3d
!
END INTERFACE
!
END MODULE modi_read_and_send_mpi
!
SUBROUTINE read_and_send_mpi_n1d(KWORK,KWORK2,KMASK,KPIO,KDX)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, nreq, &
                            xtime_npio_read, xtime_comm_read, idx_r, wlog_mpi
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
INTEGER, DIMENSION(:), INTENT(IN) :: KWORK
INTEGER, DIMENSION(:), INTENT(OUT) :: KWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
INTEGER, DIMENSION(NSIZE,NPROC) :: IWORKS
INTEGER, DIMENSION(NSIZE) :: IWORKR
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
INTEGER, DIMENSION(MPI_STATUS_SIZE,NPROC-1) :: ISTATUS2
#endif
INTEGER :: ICPT, IPIO, IDX, IREQ
INTEGER :: I,J
INTEGER :: INFOMPI
DOUBLE PRECISION :: XTIME0
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_1',0,zhook_handle)
!
IF (PRESENT(kpio)) THEN
  ipio = kpio
ELSE
  ipio = npio
ENDIF
!
IF (PRESENT(kdx)) THEN
  idx = kdx
ELSE
  idx = idx_r
ENDIF
!
IF (nrank==ipio) THEN
  !
  idx = idx + 1
  !
  IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_1',1,zhook_handle)
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(I,ICPT,J,IREQ,INFOMPI,ZHOOK_HANDLE_OMP)
  DO i=0,nproc-1
    !
    IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_20',0,zhook_handle_omp)  
    !
#ifdef SFX_MPI    
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !
    iworks(:,i+1) = 0
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==i ) THEN
        icpt = icpt + 1
        iworks(icpt,i+1) = kwork(j)
      ENDIF
      !
    ENDDO
    !
    IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_20',1,zhook_handle_omp)
    IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_30',0,zhook_handle_omp)
    !  
#ifdef SFX_MPI    
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
#endif    
    !  
    IF (i/=ipio) THEN

#ifdef SFX_MPI
      xtime0 = mpi_wtime()

      IF (PRESENT(kpio) .AND.PRESENT(kdx)) THEN
        IF (i<ipio) THEN
          ireq = i+1
        ELSE
          ireq = i
        ENDIF   
     
        CALL mpi_isend(iworks(:,i+1),SIZE(iworks,1)*kind(iworks)/4,&
                           mpi_integer,i,idx,ncomm,nreq(ireq),infompi)
      ELSE                
        CALL mpi_send(iworks(:,i+1),SIZE(iworks,1)*kind(iworks)/4,mpi_integer,i,idx,ncomm,infompi)
      ENDIF
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif

    ELSE
      iworkr(:) = iworks(:,i+1)
    ENDIF
    IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_30',1,zhook_handle_omp)
    !
  ENDDO
!$OMP END PARALLEL DO
  ! 
ELSE
  ! 
  idx = idx + 1
  !  
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_1',1,zhook_handle)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_2',0,zhook_handle)  
#ifdef SFX_MPI
  !  
  xtime0 = mpi_wtime()
  CALL mpi_recv(iworkr,SIZE(iworkr)*kind(iworkr)/4,mpi_integer,ipio,idx,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
  IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_2',1,zhook_handle)
  !  
ENDIF
!
  IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_3',0,zhook_handle)
IF (PRESENT(kmask)) THEN
  CALL pack_same_rank(kmask,iworkr(:),kwork2)
ELSE
  kwork2(:) = iworkr(1:SIZE(kwork2))
ENDIF
!
IF (.NOT.PRESENT(kdx)) idx_r = idx_r + 1
!
  IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D_3',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_n1d
!
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_n2d(KWORK,KWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, idx_r, wlog_mpi
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
INTEGER, DIMENSION(:,:), INTENT(IN) :: KWORK
INTEGER, DIMENSION(:,:), INTENT(OUT) :: KWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
INTEGER, DIMENSION(NSIZE,SIZE(KWORK2,2)) :: IWORKS
INTEGER, DIMENSION(NSIZE,SIZE(KWORK2,2)) :: IWORKR
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: IS2, IP2
INTEGER :: ICPT
INTEGER :: I,J, K
INTEGER :: INFOMPI
DOUBLE PRECISION :: XTIME0
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N2D',0,zhook_handle)
!
IF (nrank==npio) THEN
  !
  idx_r = idx_r + 1
  !
  DO i=0,nproc-1
    !
#ifdef SFX_MPI    
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !
    iworks(:,:) = 0
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        iworks(icpt,:) = kwork(j,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI    
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
    !  
    IF (i/=npio) THEN
      xtime0 = mpi_wtime()
      CALL mpi_send(iworks(:,:),SIZE(iworks)*kind(iworks)/4,mpi_integer,i,idx_r,ncomm,infompi)
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
    ELSE
      iworkr(:,:) = iworks(:,:)
    ENDIF
#endif
    !
  ENDDO
  !
ELSE
  !
  idx_r = idx_r + 1
  !  
#ifdef SFX_MPI
  iworks(:,:) = 0
  !  
  xtime0 = mpi_wtime()
  CALL mpi_recv(iworkr(:,:),SIZE(iworkr)*kind(iworkr)/4,mpi_integer,npio,idx_r,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
ENDIF
!
IF (PRESENT(kmask)) THEN
  CALL pack_same_rank(kmask,iworkr(:,:),kwork2)
ELSE
  kwork2(:,:) = iworkr(1:SIZE(kwork2,1),:)
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N2D',1,zhook_handle)
!
!
END SUBROUTINE read_and_send_mpi_n2d
!
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_n3d(KWORK,KWORK2,KMASK,KPIO,KDX)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, idx_r, wlog_mpi, &
                            nreq
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
INTEGER, DIMENSION(:,:,:), INTENT(IN) :: KWORK
INTEGER, DIMENSION(:,:,:), INTENT(OUT) :: KWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
INTEGER, DIMENSION(NSIZE,SIZE(KWORK2,2),SIZE(KWORK2,3),NPROC) :: IWORK3S
INTEGER, DIMENSION(NSIZE,SIZE(KWORK2,2),SIZE(KWORK2,3)) :: IWORK3
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: IP2, IS2, IP3, IS3
INTEGER :: ICPT, IPIO, IDX 
INTEGER :: I,J
INTEGER :: INFOMPI, IREQ
DOUBLE PRECISION   :: XTIME0
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_1',0,zhook_handle)
!
IF (PRESENT(kpio)) THEN
  ipio = kpio
ELSE
  ipio = npio
ENDIF
!
IF (PRESENT(kdx)) THEN
  idx = kdx
ELSE
  idx = idx_r
ENDIF
!
IF (nrank==ipio) THEN
  !  
  idx = idx + 1
  !  
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_1',1,zhook_handle)
!$OMP PARALLEL DO PRIVATE(I,ICPT,J,INFOMPI,IREQ,ZHOOK_HANDLE_OMP)  
  DO i=0,nproc-1
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_2',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime0 = mpi_wtime()
#endif    
    ! 
    icpt = 0
    !
    iwork3s(:,:,:,i+1) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==i ) THEN
        icpt = icpt + 1
        iwork3s(icpt,:,:,i+1) = kwork(j,:,:)
      ENDIF
      !
    ENDDO
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_2',1,zhook_handle_omp)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_3',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
#endif    
    !    
    IF (i/=ipio) THEN
#ifdef SFX_MPI              
      IF (PRESENT(kpio).AND.PRESENT(kdx)) THEN
        IF (i<ipio) THEN
          ireq = i+1
        ELSE
          ireq = i
        ENDIF            
        xtime0 = mpi_wtime()
        CALL mpi_isend(iwork3s(:,:,:,i+1),SIZE(iwork3)*kind(iwork3)/4,&
                        mpi_integer,i,idx,ncomm,nreq(ireq),infompi)
      ELSE            
        CALL mpi_send(iwork3s(:,:,:,i+1),SIZE(iwork3)*kind(iwork3)/4,&
                       mpi_integer,i,idx,ncomm,infompi)
      ENDIF
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif      
    ELSE
      iwork3(:,:,:) = iwork3s(:,:,:,i+1)
    ENDIF
    !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_3',1,zhook_handle_omp)
  ENDDO
!$OMP END PARALLEL DO
  !  
ELSE
  !  
  idx = idx + 1
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_1',1,zhook_handle)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_2',0,zhook_handle)  
#ifdef SFX_MPI 
  !
  xtime0 = mpi_wtime()  
  CALL mpi_recv(iwork3,SIZE(iwork3)*kind(iwork3)/4,mpi_integer,ipio,idx,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_2',1,zhook_handle)
  !  
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_4',0,zhook_handle)
IF (PRESENT(kmask)) THEN
  CALL pack_same_rank(kmask,iwork3(:,:,:),kwork2)
ELSE
  kwork2(:,:,:) = iwork3(1:SIZE(kwork2,1),:,:)
ENDIF
!
IF (.NOT.PRESENT(kdx)) idx_r = idx_r + 1
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N3D_4',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_n3d
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_x1d(PWORK,PWORK2,KMASK,KPIO,KDX)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, nreq, &
                            xtime_npio_read, xtime_comm_read, wlog_mpi, idx_r,&
                            nsize, xworks
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
REAL, DIMENSION(:), INTENT(IN) :: PWORK
REAL, DIMENSION(:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
REAL, DIMENSION(NSIZE,NPROC) :: ZWORKS
REAL, DIMENSION(NSIZE) :: ZWORKR
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: ICPT, IPIO, IDX
INTEGER :: I,J, IREQ
INTEGER :: INFOMPI
DOUBLE PRECISION   :: XTIME0
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_1',0,zhook_handle)
!
!
IF (PRESENT(kpio)) THEN
  ipio = kpio
ELSE
  ipio = npio
ENDIF
!
IF (nrank==ipio.AND..NOT.ALLOCATED(xworks)) ALLOCATE(xworks(nsize,nproc))
!
IF (PRESENT(kdx)) THEN
  idx = kdx
ELSE
  idx = idx_r
ENDIF
!
IF (nrank==ipio) THEN
  !
  idx = idx + 1
  !
  IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_1',1,zhook_handle)
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(I,ICPT,J,IREQ,INFOMPI,ZHOOK_HANDLE_OMP)
  DO i=0,nproc-1
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_2',0,zhook_handle_omp)
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !
    xworks(:,i+1) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==i) THEN
        icpt = icpt + 1
        xworks(icpt,i+1) = pwork(j)
      ENDIF
      !
    ENDDO
     !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_2',1,zhook_handle_omp)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_30',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
#endif    
    !
    IF (i/=ipio) THEN
#ifdef SFX_MPI              
      xtime0 = mpi_wtime()
      IF (PRESENT(kpio).AND.PRESENT(kdx)) THEN
        IF (i<ipio) THEN
          ireq = i+1
        ELSE
          ireq = i
        ENDIF
        CALL mpi_isend(xworks(:,i+1),SIZE(xworks(:,i+1))*kind(xworks)/4,mpi_real,i,idx,ncomm,nreq(ireq),infompi)
      ELSE
        CALL mpi_send(xworks(:,i+1),SIZE(xworks(:,i+1))*kind(xworks)/4,mpi_real,i,idx,ncomm,infompi)
      ENDIF
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif      
    ELSE
      zworkr(:) = xworks(:,i+1)
  ENDIF
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_30',1,zhook_handle_omp)
    !
  ENDDO
!$OMP END PARALLEL DO
  !
ELSE
  !
  idx = idx + 1
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_1',1,zhook_handle)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_2',0,zhook_handle)
#ifdef SFX_MPI
  zworkr(:) = 0.
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_2',1,zhook_handle)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_3',0,zhook_handle)
  xtime0 = mpi_wtime()
  CALL mpi_recv(zworkr(:),SIZE(zworkr(:))*kind(zworkr)/4,mpi_real,ipio,idx,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_3',1,zhook_handle)
  !
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_4',0,zhook_handle)

IF (PRESENT(kmask)) THEN
  CALL pack_same_rank(kmask,zworkr(:),pwork2(:))
ELSE
  pwork2(:) = zworkr(1:SIZE(pwork2))
ENDIF

IF (.NOT.PRESENT(kdx)) idx_r = idx_r + 1
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D_4',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_x1d
!
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_x2d(PWORK,PWORK2,KMASK,KPIO,KDX)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, wlog_mpi, idx_r, &
                            nreq, xwork2s
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
REAL, DIMENSION(:,:), INTENT(IN) :: PWORK
REAL, DIMENSION(:,:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2),NPROC) :: ZWORK2S
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2)) :: ZWORK2
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: IS2, IP2
INTEGER :: ICPT, IPIO, IDX
INTEGER :: I,J, K, IREQ
INTEGER :: INFOMPI
DOUBLE PRECISION   :: XTIME0
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_1',0,zhook_handle)
!
IF (PRESENT(kpio)) THEN
  ipio = kpio
ELSE
  ipio = npio
ENDIF
!
IF (nrank==ipio) THEN
  IF (ALLOCATED(xwork2s)) THEN
    IF (SIZE(xwork2s,2)/=SIZE(pwork2,2)) DEALLOCATE(xwork2s)
  ENDIF
  IF (.NOT.ALLOCATED(xwork2s)) ALLOCATE(xwork2s(nsize,SIZE(pwork2,2),nproc))
ENDIF
!
IF (PRESENT(kdx)) THEN
  idx = kdx
ELSE
  idx = idx_r
ENDIF
!
IF (nrank==ipio) THEN
  !
  idx = idx + 1
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_1',1,zhook_handle)
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(I,ICPT,J,IREQ,INFOMPI,ZHOOK_HANDLE_OMP)
  DO i=0,nproc-1
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_2',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime0 = mpi_wtime()
#endif    
    !
    icpt = 0
    !    
    xwork2s(:,:,i+1) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==i ) THEN
        icpt = icpt + 1
        xwork2s(icpt,:,i+1) = pwork(j,:)
      ENDIF
      !
    ENDDO
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_2',1,zhook_handle_omp)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_3',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
#endif    
    !
    IF (i/=ipio) THEN
#ifdef SFX_MPI              
      IF (PRESENT(kpio).AND.PRESENT(kdx)) THEN
        IF (i<ipio) THEN
          ireq = i+1
        ELSE
          ireq = i
        ENDIF     
        CALL mpi_isend(xwork2s(:,:,i+1),SIZE(xwork2s(:,:,i+1))*kind(xwork2s)/4,&
                        mpi_real,i,idx,ncomm,nreq(ireq),infompi)
      ELSE
        CALL mpi_send(xwork2s(:,:,i+1),SIZE(xwork2s(:,:,i+1))*kind(xwork2s)/4,&
                        mpi_real,i,idx,ncomm,infompi)
      ENDIF
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif      
    ELSE
      zwork2(:,:) = xwork2s(:,:,i+1)
    ENDIF
    !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_3',1,zhook_handle_omp)
  ENDDO
!$OMP END PARALLEL DO
  !
ELSE
  !
  idx = idx + 1
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_1',1,zhook_handle)
#ifdef SFX_MPI
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_3',0,zhook_handle)
  !
  xtime0 = mpi_wtime()
  CALL mpi_recv(zwork2(:,:),SIZE(zwork2)*kind(zwork2)/4,mpi_real,ipio,idx,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_3',1,zhook_handle)
  !  
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_4',0,zhook_handle)
!
IF (PRESENT(kmask)) THEN
  CALL pack_same_rank(kmask,zwork2(:,:),pwork2(:,:))
ELSE
  pwork2(:,:) = zwork2(1:SIZE(pwork2,1),:)
ENDIF
!
IF (.NOT.PRESENT(kdx)) idx_r = idx_r + 1
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D_4',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_x2d
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_x3d(PWORK,PWORK2,KMASK,KPIO,KDX)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, idx_r, wlog_mpi, &
                            nreq
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PWORK
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
INTEGER, INTENT(IN), OPTIONAL :: KPIO
INTEGER, INTENT(IN), OPTIONAL :: KDX
!
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2),SIZE(PWORK2,3),NPROC) :: ZWORK3S
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2),SIZE(PWORK2,3)) :: ZWORK3
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: IP2, IS2, IP3, IS3
INTEGER :: ICPT, IPIO, IDX 
INTEGER :: I,J
INTEGER :: INFOMPI, IREQ
DOUBLE PRECISION   :: XTIME0
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_1',0,zhook_handle)
!
IF (PRESENT(kpio)) THEN
  ipio = kpio
ELSE
  ipio = npio
ENDIF
!
IF (PRESENT(kdx)) THEN
  idx = kdx
ELSE
  idx = idx_r
ENDIF
!
IF (nrank==ipio) THEN
  !  
  idx = idx + 1
  !  
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_1',1,zhook_handle)
!$OMP PARALLEL DO PRIVATE(I,ICPT,J,IREQ,INFOMPI,ZHOOK_HANDLE_OMP)  
  DO i=0,nproc-1
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_2',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime0 = mpi_wtime()
#endif    
    ! 
    icpt = 0
    !
    zwork3s(:,:,:,i+1) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==i ) THEN
        icpt = icpt + 1
        zwork3s(icpt,:,:,i+1) = pwork(j,:,:)
      ENDIF
      !
    ENDDO
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_2',1,zhook_handle_omp)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_3',0,zhook_handle_omp)
    !
#ifdef SFX_MPI    
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
#endif    
    !    
    IF (i/=ipio) THEN
#ifdef SFX_MPI               
      IF (PRESENT(kpio).AND.PRESENT(kdx)) THEN
        IF (i<ipio) THEN
          ireq = i+1
        ELSE
          ireq = i
        ENDIF            
        xtime0 = mpi_wtime()
        CALL mpi_isend(zwork3s(:,:,:,i+1),SIZE(zwork3)*kind(zwork3)/4,&
                        mpi_real,i,idx,ncomm,nreq(ireq),infompi)
      ELSE            
        CALL mpi_send(zwork3s(:,:,:,i+1),SIZE(zwork3)*kind(zwork3)/4,&
                       mpi_real,i,idx,ncomm,infompi)
      ENDIF
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif      
    ELSE
      zwork3(:,:,:) = zwork3s(:,:,:,i+1)     
    ENDIF
    !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_3',1,zhook_handle_omp)
  ENDDO
!$OMP END PARALLEL DO 
  !  
ELSE
  !  
  idx = idx + 1
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_1',1,zhook_handle)
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_2',0,zhook_handle)  
#ifdef SFX_MPI 
  !
  xtime0 = mpi_wtime()  
  CALL mpi_recv(zwork3,SIZE(zwork3)*kind(zwork3)/4,mpi_real,ipio,idx,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_2',1,zhook_handle)
  !  
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_4',0,zhook_handle)
!
IF (PRESENT(kmask)) THEN
  CALL pack_same_rank(kmask,zwork3(:,:,:),pwork2)
ELSE
  pwork2(:,:,:) = zwork3(1:SIZE(pwork2,1),:,:)
ENDIF
!
IF (.NOT.PRESENT(kdx)) idx_r = idx_r + 1
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D_4',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_x3d