gather_and_write_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_gather_and_write_mpi
!----------------------------------------------------
!!    MODIFICATIONS
!!    -------------
!!      Original       
!!      J.Escobar      10/06/2013: replace DOUBLE PRECISION by REAL to handle problem for promotion of real on IBM SP
!----------------------------------------------------
!
INTERFACE gather_and_write_mpi
!
SUBROUTINE gather_and_write_mpi_n1d(KWORK,KWORK2,KMASK)
!
INTEGER, DIMENSION(:), INTENT(IN) :: kwork
INTEGER, DIMENSION(:), INTENT(OUT) :: kwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_n1d
!
SUBROUTINE gather_and_write_mpi_n2d(KWORK,KWORK2,KMASK)
!
INTEGER, DIMENSION(:,:), INTENT(IN) :: kwork
INTEGER, DIMENSION(:,:), INTENT(OUT) :: kwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_n2d
!
SUBROUTINE gather_and_write_mpi_x1d(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:), INTENT(IN) :: pwork
REAL(KIND=8), DIMENSION(:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_x1d
!
SUBROUTINE gather_and_write_mpi_x2d(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:,:), INTENT(IN) :: pwork
REAL(KIND=8), DIMENSION(:,:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_x2d
!
SUBROUTINE gather_and_write_mpi_x1dk4(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:), INTENT(IN) :: pwork
REAL(KIND=4), DIMENSION(:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_x1dk4
!
SUBROUTINE gather_and_write_mpi_x2dk4(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:,:), INTENT(IN) :: pwork
REAL(KIND=4), DIMENSION(:,:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_x2dk4
!
END INTERFACE
!
END MODULE modi_gather_and_write_mpi
!
SUBROUTINE gather_and_write_mpi_n1d(KWORK,KWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_calc_write, xtime_comm_write, &
                            xtime_omp_barr, idx_w, wlog_mpi
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, nwork, nwork_full
!
USE modi_unpack_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) :: iinter
REAL   :: xtime0
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: icpt
INTEGER :: i,j, ip1, is1
INTEGER :: infompi
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N1D',0,zhook_handle)
!
!$OMP BARRIER
!
nwork(nindx1sfx:nindx2sfx) = 0
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (present(kmask)) THEN
  CALL unpack_same_rank(kmask,kwork,nwork(nindx1sfx:nindx2sfx))
ELSE
  nwork(nindx1sfx:nindx2sfx) = kwork(:)
ENDIF
!
#ifdef SFX_MPI
xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
!
xtime0 = mpi_wtime()
#endif
!
!$OMP BARRIER
!
#ifdef SFX_MPI
xtime_omp_barr = xtime_omp_barr + (mpi_wtime() - xtime0)
#endif
!
IF (nrank/=npio) THEN
  !
!$OMP SINGLE
  !
  idx_w = idx_w + 1
  !  
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
  CALL mpi_send(nwork,SIZE(nwork)*kind(nwork)/4,mpi_integer,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !  
ELSE
  !
  ip1 = SIZE(kwork2)
  !
!$OMP SINGLE
  !
  is1 = SIZE(nwork_full)
  !
  IF (ip1>is1) THEN
    DEALLOCATE(nwork_full)
    ALLOCATE(nwork_full(ip1))
  ENDIF
  !
  nwork_full(:) = 0
  !
  idx_w = idx_w + 1 
  !
  DO i=1,nproc
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    IF (i<nproc) THEN
#ifdef SFX_MPI
      CALL mpi_recv(iinter,SIZE(iinter)*kind(iinter)/4,mpi_integer,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      iinter(1:SIZE(nwork)) = nwork(:)
    ENDIF
    !
#ifdef SFX_MPI
    xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
    !
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !    
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        nwork_full(j) = iinter(icpt)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
    !
  ENDDO
  !
!$OMP END SINGLE
  !
  kwork2(:) = nwork_full(1:ip1)
  !
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N1D',1,zhook_handle)
!
!
END SUBROUTINE gather_and_write_mpi_n1d
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_n2d(KWORK,KWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_calc_write, xtime_comm_write, &
                            xtime_omp_barr, idx_w, wlog_mpi
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, nwork2, nwork2_full
!
USE modi_unpack_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)) :: iinter
REAL   :: xtime0
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: istatus
#endif
INTEGER :: icpt, ix2, is1, is2, ip1, ip2
INTEGER :: i,j
INTEGER :: infompi
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N2D',0,zhook_handle)
!
ip2 = SIZE(kwork,2)
ix2 = SIZE(nwork2,2)
!
!$OMP SINGLE
!
IF (ip2>ix2) THEN
  DEALLOCATE(nwork2)
  ALLOCATE(nwork2(nsize,ip2))
ENDIF
!
!$OMP END SINGLE
!
nwork2(nindx1sfx:nindx2sfx,1:ip2) = 0
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(kwork,1)>0) THEN
  IF (present(kmask)) THEN
    CALL unpack_same_rank(kmask,kwork,nwork2(nindx1sfx:nindx2sfx,1:ip2))
  ELSE
    nwork2(nindx1sfx:nindx2sfx,1:ip2) = kwork(:,:)
  ENDIF
ENDIF
!
#ifdef SFX_MPI
xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
!
xtime0 = mpi_wtime()
#endif
!
!$OMP BARRIER
!
#ifdef SFX_MPI
xtime_omp_barr = xtime_omp_barr + (mpi_wtime() - xtime0)
#endif
!
IF (nrank/=npio) THEN
  !
!$OMP SINGLE
  !
  idx_w = idx_w + 1
  !  
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
  CALL mpi_send(nwork2(:,1:ip2),nsize*ip2*kind(nwork2)/4,mpi_integer,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !  
ELSE
  !
  ip1 = SIZE(kwork2,1)
  !
!$OMP SINGLE
  !
  is1 = SIZE(nwork2_full,1)
  is2 = SIZE(nwork2_full,2)  
  !
  IF (ip1>is1 .OR. ip2>is2) THEN
    DEALLOCATE(nwork2_full)
    ALLOCATE(nwork2_full(max(ip1,is1),max(ip2,is2)))
  ENDIF  
  !
  nwork2_full(:,:) = 0
  !
  idx_w = idx_w + 1 
  !
  DO i=1,nproc
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    IF (i<nproc) THEN
#ifdef SFX_MPI
      CALL mpi_recv(iinter,SIZE(iinter)*kind(iinter)/4,mpi_integer,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      iinter(:,:) = nwork2(:,1:ip2)
    ENDIF
    !
#ifdef SFX_MPI
    xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
    !
    xtime0 = mpi_wtime()
#endif
    !
    icpt = 0
    !  
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==mod(i,nproc) ) THEN
        icpt = icpt + 1
        nwork2_full(j,1:ip2) = iinter(icpt,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
    !
  ENDDO
  !
!$OMP END SINGLE
  !
  kwork2(:,:) = nwork2_full(1:ip1,1:ip2)
  !
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N2D',1,zhook_handle)
!
!
END SUBROUTINE gather_and_write_mpi_n2d
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x1d(PWORK,PWORK2,KMASK)
!
USE modi_gather_and_write_mpi_k4
!
USE modd_surfex_mpi, ONLY : nrank, npio
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
REAL, DIMENSION(:), INTENT(IN) :: pwork
REAL(KIND=8), DIMENSION(:), INTENT(OUT) :: pwork2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
REAL, DIMENSION(SIZE(PWORK2)) :: zinter
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X1D',0,zhook_handle)
!
IF (present(kmask)) THEN
  CALL gather_and_write_mpi_k4(pwork,zinter,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,zinter)
ENDIF
!
IF (nrank==npio) THEN
  pwork2(:) = zinter(:)
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X1D',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x1d
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x2d(PWORK,PWORK2,KMASK)
!
USE modi_gather_and_write_mpi_k4
!
USE modd_surfex_mpi, ONLY : nrank, npio
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
REAL, DIMENSION(:,:), INTENT(IN) :: pwork
REAL(KIND=8), DIMENSION(:,:), INTENT(OUT) :: pwork2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
REAL, DIMENSION(SIZE(PWORK2,1),SIZE(PWORK2,2)) :: zinter
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2D',0,zhook_handle)
!
IF (present(kmask)) THEN
  CALL gather_and_write_mpi_k4(pwork,zinter,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,zinter)
ENDIF
!
IF (nrank==npio) THEN
  pwork2(:,:) = zinter(:,:)
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2D',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x2d
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x1dk4(PWORK,PWORK2,KMASK)
!
USE modi_gather_and_write_mpi_k4
!
USE modd_surfex_mpi, ONLY : nrank, npio
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
REAL, DIMENSION(:), INTENT(IN) :: pwork
REAL(KIND=4), DIMENSION(:), INTENT(OUT) :: pwork2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
REAL, DIMENSION(SIZE(PWORK2)) :: zinter
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X1DK4',0,zhook_handle)
!
IF (present(kmask)) THEN
  CALL gather_and_write_mpi_k4(pwork,zinter,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,zinter)
ENDIF
!
IF (nrank==npio) THEN
  pwork2(:) = zinter(:)
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X1DK4',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x1dk4
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x2dk4(PWORK,PWORK2,KMASK)
!
USE modi_gather_and_write_mpi_k4
!
USE modd_surfex_mpi, ONLY : nrank, npio
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
REAL, DIMENSION(:,:), INTENT(IN) :: pwork
REAL(KIND=4), DIMENSION(:,:), INTENT(OUT) :: pwork2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
REAL, DIMENSION(SIZE(PWORK2,1),SIZE(PWORK2,2)) :: zinter
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2DK4',0,zhook_handle)
!
IF (present(kmask)) THEN
  CALL gather_and_write_mpi_k4(pwork,zinter,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,zinter)
ENDIF
!
IF (nrank==npio) THEN
  pwork2(:,:) = zinter(:,:)
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2DK4',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x2dk4