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.
!----------------------------------------------------
!!    MODIFICATIONS
!!    -------------
!!      Original       
!!      J.Escobar      10/06/2013: replace DOUBLE PRECISION by REAL to handle problem for promotion of real on IBM SP
!----------------------------------------------------
!
MODULE modi_read_and_send_mpi
!
INTERFACE read_and_send_mpi
!
SUBROUTINE read_and_send_mpi_n1d(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_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_x1d(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:), INTENT(IN) :: pwork
REAL, DIMENSION(:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE read_and_send_mpi_x1d
!
SUBROUTINE read_and_send_mpi_x2d(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:,:), INTENT(IN) :: pwork
REAL, DIMENSION(:,:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE read_and_send_mpi_x2d
!
SUBROUTINE read_and_send_mpi_x3d(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: pwork
REAL, DIMENSION(:,:,:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
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)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, idx_r, wlog_mpi
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, nwork, nblock
!
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
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: icpt
INTEGER :: i,j
INTEGER :: infompi
REAL :: xtime0
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D',0,zhook_handle)
!
!$OMP BARRIER
!
IF (nrank==npio) THEN
  !
!$OMP SINGLE 
  !
  idx_r = idx_r + 1
  !
  DO i=1,nproc-1
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !
    nwork(:) = 0
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        nwork(icpt) = kwork(j)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
    !  
    IF (i<nproc) THEN
      xtime0 = mpi_wtime()
      CALL mpi_send(nwork,SIZE(nwork)*kind(nwork)/4,mpi_integer,i,idx_r,ncomm,infompi)
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
    ENDIF
#endif
    !
  ENDDO
  !
!$OMP END SINGLE 
  ! 
ELSE
  !
!$OMP SINGLE
  ! 
  idx_r = idx_r + 1
  !  
#ifdef SFX_MPI
  nwork(:) = 0
  !  
  xtime0 = mpi_wtime()
  CALL mpi_recv(nwork,SIZE(nwork)*kind(nwork)/4,mpi_integer,npio,idx_r,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !
ENDIF
!
IF (present(kmask)) THEN
  CALL pack_same_rank(kmask,nwork(nindx1sfx:nindx2sfx),kwork2)
ELSE
  kwork2(:) = nwork(nindx1sfx:nindx2sfx)
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N1D',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 modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, nwork2, nblock
!
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
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: is2, ip2
INTEGER :: icpt
INTEGER :: i,j, k
INTEGER :: infompi
REAL xtime0
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_N2D',0,zhook_handle)
!
!$OMP BARRIER
!
ip2 = SIZE(kwork2,2)
is2 = SIZE(nwork2,2)
!
!$OMP SINGLE
IF (ip2>is2) THEN
  DEALLOCATE(nwork2)
  ALLOCATE(nwork2(nsize,ip2))
ENDIF
!$OMP END SINGLE
!
IF (nrank==npio) THEN
  !
!$OMP SINGLE 
  !
  idx_r = idx_r + 1
  !
  DO i=1,nproc-1
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !
    nwork2(:,1:ip2) = 0
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        nwork2(icpt,1:ip2) = kwork(j,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
    !  
    IF (i<nproc) THEN
      xtime0 = mpi_wtime()
      CALL mpi_send(nwork2(:,1:ip2),nsize*ip2*kind(nwork2)/4,mpi_integer,i,idx_r,ncomm,infompi)
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
    ENDIF
#endif
    !
  ENDDO
  !
!$OMP END SINGLE 
  ! 
ELSE
  !
!$OMP SINGLE
  ! 
  idx_r = idx_r + 1
  !  
#ifdef SFX_MPI
  nwork2(:,1:ip2) = 0
  !  
  xtime0 = mpi_wtime()
  CALL mpi_recv(nwork2(:,1:ip2),nsize*ip2*kind(nwork2)/4,mpi_integer,npio,idx_r,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !
ENDIF
!
IF (present(kmask)) THEN
  CALL pack_same_rank(kmask,nwork2(nindx1sfx:nindx2sfx,1:ip2),kwork2)
ELSE
  kwork2(:,:) = nwork2(nindx1sfx:nindx2sfx,1:ip2)
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_x1d(PWORK,PWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, wlog_mpi, idx_r
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, xwork, nblock             
!
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
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: icpt
INTEGER :: i,j
INTEGER :: infompi
REAL   :: xtime0
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D',0,zhook_handle)
!
!$OMP BARRIER
!
IF (nrank==npio) THEN
  !
!$OMP SINGLE
  !
  idx_r = idx_r + 1
  !
  DO i=1,nproc
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !
    xwork(:) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        xwork(icpt) = pwork(j)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
    !
    IF (i<nproc) THEN
      xtime0 = mpi_wtime()
      CALL mpi_send(xwork,SIZE(xwork)*kind(xwork)/4,mpi_real,i,idx_r,ncomm,infompi)
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
    ENDIF
#endif
    !
  ENDDO
  !
!$OMP END SINGLE
!
ELSE
  !
!$OMP SINGLE
  !  
  idx_r = idx_r + 1
  !
#ifdef SFX_MPI
  xwork(:) = 0.
  !
  xtime0 = mpi_wtime()
  CALL mpi_recv(xwork,SIZE(xwork)*kind(xwork)/4,mpi_real,npio,idx_r,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !
ENDIF
!
IF (present(kmask)) THEN
  CALL pack_same_rank(kmask,xwork(nindx1sfx:nindx2sfx),pwork2)
ELSE
  pwork2(:) = xwork(nindx1sfx:nindx2sfx)
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X1D',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_x1d
!
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_x2d(PWORK,PWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, wlog_mpi, idx_r
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, xwork2, nblock
!
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
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: is2, ip2
INTEGER :: icpt
INTEGER :: i,j, k
INTEGER :: infompi
REAL   :: xtime0
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D',0,zhook_handle)
!
!$OMP BARRIER
!
ip2 = SIZE(pwork2,2)
is2 = SIZE(xwork2,2)
!
!$OMP SINGLE
IF (ip2>is2) THEN
  DEALLOCATE(xwork2)
  ALLOCATE(xwork2(nsize,ip2))
ENDIF
!$OMP END SINGLE
!
IF (nrank==npio) THEN
  !
!$OMP SINGLE
  !  
  idx_r = idx_r + 1
  !
  DO i=1,nproc
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !    
    xwork2(:,1:ip2) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        xwork2(icpt,1:ip2) = pwork(j,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
    !
    IF (i<nproc) THEN
      xtime0 = mpi_wtime()
      CALL mpi_send(xwork2(:,1:ip2),nsize*ip2*kind(xwork2)/4,mpi_real,i,idx_r,ncomm,infompi)
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
    ENDIF
#endif
    !
  ENDDO
  !
!$OMP END SINGLE
  !  
ELSE
  !
!$OMP SINGLE
  !
  idx_r = idx_r + 1
  !
#ifdef SFX_MPI
  xwork2(:,1:ip2) = 0.
  !
  xtime0 = mpi_wtime()
  CALL mpi_recv(xwork2(:,1:ip2),nsize*ip2*kind(xwork2)/4,mpi_real,npio,idx_r,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !  
ENDIF
!
IF (present(kmask)) THEN
  CALL pack_same_rank(kmask,xwork2(nindx1sfx:nindx2sfx,1:ip2),pwork2)
ELSE
  pwork2(:,:) = xwork2(nindx1sfx:nindx2sfx,1:ip2)
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X2D',1,zhook_handle)
!
END SUBROUTINE read_and_send_mpi_x2d
!**************************************************************************
!
SUBROUTINE read_and_send_mpi_x3d(PWORK,PWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_npio_read, xtime_comm_read, idx_r, wlog_mpi
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, xwork3, nblock
!
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
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: ip2, is2, ip3, is3
INTEGER :: icpt 
INTEGER :: i,j
INTEGER :: infompi
REAL   :: xtime0
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D',0,zhook_handle)
!
!$OMP BARRIER
!
ip2 = SIZE(pwork2,2)
ip3 = SIZE(pwork2,3)
is2 = SIZE(xwork3,2)
is3 = SIZE(xwork3,3)
!
!$OMP SINGLE
IF (ip2>is2 .OR. ip3>is3) THEN
  DEALLOCATE(xwork3)
  ALLOCATE(xwork3(nsize,max(ip2,is2),max(ip3,is3)))
ENDIF
!$OMP END SINGLE
!
IF (nrank==npio) THEN
  !
!$OMP SINGLE
  !  
  idx_r = idx_r + 1
  !  
  DO i=1,nproc
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    ! 
    icpt = 0
    !
    xwork3(:,1:ip2,1:ip3) = 0.
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        xwork3(icpt,1:ip2,1:ip3) = pwork(j,:,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
    !
    IF (i<nproc) THEN
      xtime0 = mpi_wtime()
      CALL mpi_send(xwork3(:,1:ip2,1:ip3),nsize*ip2*ip3*kind(xwork3)/4,mpi_real,i,idx_r,ncomm,infompi)
      xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
    ENDIF
#endif
    !
  ENDDO
  !
!$OMP END SINGLE
  !  
ELSE
  !
!$OMP SINGLE
  !  
  idx_r = idx_r + 1
  !
#ifdef SFX_MPI
  xwork3(:,1:ip2,1:ip3) = 0.
  !
  xtime0 = mpi_wtime()  
  CALL mpi_recv(xwork3(:,1:ip2,1:ip3),nsize*ip2*ip3*kind(xwork3)/4,mpi_real,npio,idx_r,ncomm,istatus,infompi)
  xtime_comm_read = xtime_comm_read + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !  
ENDIF
!
IF (present(kmask)) THEN
  CALL pack_same_rank(kmask,xwork3(nindx1sfx:nindx2sfx,1:ip2,1:ip3),pwork2)
ELSE
  pwork2(:,:,:) = xwork3(nindx1sfx:nindx2sfx,1:ip2,1:ip3)
ENDIF
!
IF (lhook) CALL dr_hook('READ_AND_SEND_MPI_X3D',1,zhook_handle)
!
!
END SUBROUTINE read_and_send_mpi_x3d