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_n3d(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_n3d
!
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_x3d(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_x3d
!
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
!
SUBROUTINE gather_and_write_mpi_x3dk4(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_x3dk4
!
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, &
                            idx_w, wlog_mpi
!
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
INTEGER, DIMENSION(NSIZE) :: IWORK
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, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N1D',0,zhook_handle)
!
iwork(:) = 0
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (PRESENT(kmask)) THEN
  CALL unpack_same_rank(kmask,kwork,iwork(:))
ELSE
  iwork(1:SIZE(kwork)) = kwork(:)
ENDIF
!
#ifdef SFX_MPI
xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
!
xtime0 = mpi_wtime()
#endif
!
IF (nrank/=npio) THEN
  !
  idx_w = idx_w + 1
  !  
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
  CALL mpi_send(iwork,SIZE(iwork)*kind(iwork)/4,mpi_integer,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
ELSE
  !
  kwork2(:) = 0        
  !
  idx_w = idx_w + 1 
  !
  DO i=0,nproc-1
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    IF (i/=npio) THEN
#ifdef SFX_MPI
      CALL mpi_recv(iinter,SIZE(iinter)*kind(iinter)/4,mpi_integer,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      iinter(:) = iwork(:)
    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)==i ) THEN
        icpt = icpt + 1
        kwork2(j) = iinter(icpt)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
    !
  ENDDO
  !
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, &
                            idx_w, wlog_mpi
!
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
INTEGER, DIMENSION(NSIZE,SIZE(KWORK2,2)) :: IWORK
REAL   :: XTIME0
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: ICPT
INTEGER :: I,J
INTEGER :: INFOMPI
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N2D',0,zhook_handle)
!
iwork(:,:) = 0
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(kwork,1)>0) THEN
  IF (PRESENT(kmask)) THEN
    CALL unpack_same_rank(kmask,kwork,iwork(:,:))
  ELSE
    iwork(1:SIZE(kwork,1),:) = kwork(:,:)
  ENDIF
ENDIF
!
#ifdef SFX_MPI
xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
!
xtime0 = mpi_wtime()
#endif
!
IF (nrank/=npio) THEN
  !
  idx_w = idx_w + 1
  !  
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
  CALL mpi_send(iwork(:,:),SIZE(iwork)*kind(iwork)/4,mpi_integer,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
ELSE
  !
  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(:,:) = iwork(:,:)
    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
        kwork2(j,:) = iinter(icpt,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
    !
  ENDDO
  !
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_n3d(KWORK,KWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_calc_write, xtime_comm_write, &
                            idx_w, wlog_mpi
!
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),SIZE(KWORK2,3)) :: IINTER
INTEGER, DIMENSION(NSIZE,SIZE(KWORK,2),SIZE(KWORK,3)) :: IWORK
!
DOUBLE PRECISION   :: XTIME0
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: ICPT
INTEGER :: I,J
INTEGER :: INFOMPI
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N3D',0,zhook_handle)
!
iwork(:,:,:) = 0
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(kwork,1)>0) THEN
  IF (PRESENT(kmask)) THEN
    CALL unpack_same_rank(kmask,kwork(:,:,:),iwork(:,:,:))
  ELSE
    iwork(1:SIZE(kwork,1),:,:) = kwork(:,:,:)
  ENDIF
ENDIF
!
#ifdef SFX_MPI
xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
!
xtime0 = mpi_wtime()
#endif
!
IF (nrank/=npio) THEN
  !
  idx_w = idx_w + 1
  !  
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
  CALL mpi_send(iwork(:,:,:),SIZE(iwork)*kind(iwork)/4,mpi_integer,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
ELSE
  ! 
  kwork2(:,:,:) = 0
  !
  idx_w = idx_w + 1 
  !
  DO i=0,nproc-1
    !
#ifdef SFX_MPI    
    xtime0 = mpi_wtime()
#endif    
    !
    IF (i/=npio) THEN
#ifdef SFX_MPI
      CALL mpi_recv(iinter,SIZE(iinter)*kind(iinter)/4,mpi_integer,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      iinter(:,:,:) = iwork(:,:,:)
    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)==i ) THEN
        icpt = icpt + 1
        kwork2(j,:,:) = iinter(icpt,:,:)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI     
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif     
    !
  ENDDO
  !
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_N3D',1,zhook_handle)
!
!
END SUBROUTINE gather_and_write_mpi_n3d
!
!**************************************************************************
!
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=KIND(PWORK)), DIMENSION(:), INTENT(OUT) :: PWORK2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
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,pwork2,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,pwork2)
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=KIND(PWORK)), DIMENSION(:,:), INTENT(OUT) :: PWORK2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
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,pwork2,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,pwork2)
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_x3d(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=KIND(PWORK)), DIMENSION(:,:,:), INTENT(OUT) :: PWORK2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D',0,zhook_handle)
!
IF (PRESENT(kmask)) THEN
  CALL gather_and_write_mpi_k4(pwork,pwork2,kmask)
ELSE
  CALL gather_and_write_mpi_k4(pwork,pwork2)
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x3d
!
!**************************************************************************
!
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=KIND(PWORK)/2), DIMENSION(:), INTENT(OUT) :: PWORK2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
REAL, DIMENSION(:), ALLOCATABLE :: ZINTER
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X1DK4',0,zhook_handle)
!
ALLOCATE(zinter(SIZE(pwork2)))
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
DEALLOCATE(zinter)
!
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=KIND(PWORK)/2), DIMENSION(:,:), INTENT(OUT) :: PWORK2
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
REAL, DIMENSION(:,:), ALLOCATABLE :: ZINTER
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2DK4',0,zhook_handle)
!
ALLOCATE(zinter(SIZE(pwork2,1),SIZE(pwork2,2)))
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
DEALLOCATE(zinter)
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2DK4',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x2dk4