gather_and_write_mpi_k4.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_k4
!----------------------------------------------------
!!    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_k4
!
SUBROUTINE gather_and_write_mpi_x1d0(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:), INTENT(IN) :: pwork
REAL, DIMENSION(:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_x1d0
!
SUBROUTINE gather_and_write_mpi_x2d0(PWORK,PWORK2,KMASK)
!
REAL, DIMENSION(:,:), INTENT(IN) :: pwork
REAL, DIMENSION(:,:), INTENT(OUT) :: pwork2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: kmask
!
END SUBROUTINE gather_and_write_mpi_x2d0
!
END INTERFACE
!
END MODULE modi_gather_and_write_mpi_k4
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x1d0(PWORK,PWORK2,KMASK)
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_comm_write, xtime_calc_write, &
                            xtime_omp_barr, idx_w, wlog_mpi
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, xwork, xwork_full
!
USE modd_surf_par, ONLY : xundef
!
USE modi_unpack_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
!
REAL, DIMENSION(NSIZE) :: zinter
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_X1D0',0,zhook_handle)
!
xwork(nindx1sfx:nindx2sfx) = xundef
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(pwork)>0) THEN
  IF (present(kmask)) THEN
    CALL unpack_same_rank(kmask,pwork,xwork(nindx1sfx:nindx2sfx))
  ELSE
    xwork(nindx1sfx:nindx2sfx) = pwork(:)
  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(xwork,SIZE(xwork)*kind(xwork)/4,mpi_real,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !
ELSE
  !
  ip1 = SIZE(pwork2)
  !
!$OMP SINGLE
  ! 
  is1 = SIZE(xwork_full)
  !
  IF (ip1>is1) THEN
    DEALLOCATE(xwork_full)
    ALLOCATE(xwork_full(ip1))
  ENDIF
  !
  xwork_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(zinter,SIZE(zinter)*kind(zinter)/4,mpi_real,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      zinter(1:SIZE(xwork)) = xwork(:)
    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
        xwork_full(j) = zinter(icpt)
      ENDIF
      !
    ENDDO
    !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
    !
  ENDDO
  !
!$OMP END SINGLE
  !
  pwork2 = xwork_full(1:ip1)
  !
ENDIF
!

IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X1D0',1,zhook_handle)
!
END SUBROUTINE gather_and_write_mpi_x1d0
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x2d0(PWORK,PWORK2,KMASK)
!
USE modd_surf_par, ONLY : xundef
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_comm_write, xtime_omp_barr,  &
                            xtime_calc_write, idx_w, wlog_mpi
USE modd_surfex_omp, ONLY : nindx1sfx, nindx2sfx, xwork2, xwork2_full, nblock
!
USE modi_unpack_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
!
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2)) :: zinter
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_X2D0',0,zhook_handle)
!
ip2 = SIZE(pwork,2)
ix2 = SIZE(xwork2,2)
!
!$OMP SINGLE
!
IF (ip2>ix2) THEN
  DEALLOCATE(xwork2)
  ALLOCATE(xwork2(nsize,ip2))
ENDIF
!
!$OMP END SINGLE
!
xwork2(nindx1sfx:nindx2sfx,1:ip2) = xundef
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(pwork,1)>0) THEN
  IF (present(kmask)) THEN
    CALL unpack_same_rank(kmask,pwork,xwork2(nindx1sfx:nindx2sfx,1:ip2))
  ELSE
    xwork2(nindx1sfx:nindx2sfx,1:ip2) = pwork(:,:)
  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(xwork2(:,1:ip2),nsize*ip2*kind(xwork2)/4,mpi_real,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
!$OMP END SINGLE
  !
ELSE
  !
  ip1 = SIZE(pwork2,1)
  !
!$OMP SINGLE
  !
  is1 = SIZE(xwork2_full,1)
  is2 = SIZE(xwork2_full,2)
  !
  IF (ip1>is1 .OR. ip2>is2) THEN
    DEALLOCATE(xwork2_full)
    ALLOCATE(xwork2_full(max(ip1,is1),max(ip2,is2)))
  ENDIF
  !
  xwork2_full(1:ip1,1:ip2) = 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(zinter,SIZE(zinter)*kind(zinter)/4,mpi_real,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      zinter(:,:) = xwork2(:,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
        xwork2_full(j,1:ip2) = zinter(icpt,:)
      ENDIF
      !
    ENDDO
     !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
     !
  ENDDO
  !
!$OMP END SINGLE
  !
  pwork2(:,:) = xwork2_full(1:ip1,1:ip2)
  !
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2D0',1,zhook_handle)
!
!
END SUBROUTINE gather_and_write_mpi_x2d0
!
!**************************************************************************