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
!
SUBROUTINE gather_and_write_mpi_x3d0(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_x3d0
!
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, &
                            idx_w, wlog_mpi
!
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, DIMENSION(NSIZE) :: ZWORK
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_X1D0',0,zhook_handle)
!
zwork(:) = xundef
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(pwork)>0) THEN
  IF (PRESENT(kmask)) THEN
    CALL unpack_same_rank(kmask,pwork,zwork(:))
  ELSE
    zwork(1:SIZE(pwork)) = pwork(:)
  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(zwork,SIZE(zwork)*kind(zwork)/4,mpi_real,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
ELSE
  !
  pwork2(:) = 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(zinter,SIZE(zinter)*kind(zinter)/4,mpi_real,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      zinter(:) = zwork(:)
    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
        pwork2(j) = zinter(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_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_calc_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
!
REAL, DIMENSION(:,:), INTENT(IN) :: PWORK
REAL, DIMENSION(:,:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2)) :: ZINTER
REAL, DIMENSION(NSIZE,SIZE(PWORK,2)) :: ZWORK
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, ZHOOK_HANDLE_OMP
!
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2D0',0,zhook_handle)
!
zwork(:,:) = xundef
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(pwork,1)>0) THEN
  IF (PRESENT(kmask)) THEN
    CALL unpack_same_rank(kmask,pwork,zwork(:,:))
  ELSE
    zwork(1:SIZE(pwork,1),:) = pwork(:,:)
  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(zwork(:,:),SIZE(zwork)*kind(zwork)/4,mpi_real,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
ELSEIF (nproc>1) THEN
  !
  pwork2(:,:) = 0.
  !
  idx_w = idx_w + 1
  !  
!!$OMP PARALLEL DO PRIVATE(I,ZINTER,ICPT,J,ISTATUS,INFOMPI,ZHOOK_HANDLE_OMP)  
  DO i=0,nproc-1
    !
#ifdef SFX_MPI
    xtime0 = mpi_wtime()
#endif
    !
    IF (i/=npio) THEN
#ifdef SFX_MPI
      CALL mpi_recv(zinter,SIZE(zinter)*kind(zinter)/4,mpi_real,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      zinter(:,:) = zwork(:,:)
    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
        pwork2(j,:) = zinter(icpt,:)
      ENDIF
      !
    ENDDO
     !
#ifdef SFX_MPI
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif
     !
  ENDDO
!!$OMP END PARALLEL DO
  !
ELSE
  !
  pwork2(:,:) = zwork(:,:)
  !
ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X2D0',1,zhook_handle)
!
!
END SUBROUTINE gather_and_write_mpi_x2d0
!
!**************************************************************************
!
SUBROUTINE gather_and_write_mpi_x3d0(PWORK,PWORK2,KMASK)
!
USE modd_surf_par, ONLY : xundef
!
USE modd_surfex_mpi, ONLY : nindex, nproc, nrank, ncomm, npio, nsize, &
                            xtime_comm_write,  &
                            xtime_calc_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
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PWORK
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PWORK2
!
INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK
!
REAL, DIMENSION(NSIZE,SIZE(PWORK2,2),SIZE(PWORK2,3)) :: ZINTER
REAL, DIMENSION(NSIZE,SIZE(PWORK,2),SIZE(PWORK,3)) :: ZWORK
DOUBLE PRECISION   :: 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, ZHOOK_HANDLE_OMP
!
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_1',0,zhook_handle)
!
zwork(:,:,:) = xundef
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
IF (SIZE(pwork,1)>0) THEN
  IF (PRESENT(kmask)) THEN
    CALL unpack_same_rank(kmask,pwork(:,:,:),zwork(:,:,:))
  ELSE
    zwork(1:SIZE(pwork,1),:,:) = pwork(:,:,:)
  ENDIF
ENDIF
!
#ifdef SFX_MPI
xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
!
xtime0 = mpi_wtime()
#endif
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_1',1,zhook_handle)
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_2',0,zhook_handle)

IF (nrank/=npio) THEN
  !
  !  
  idx_w = idx_w + 1
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
  CALL mpi_send(zwork(:,:,:),SIZE(zwork)*kind(zwork)/4,mpi_real,npio,idx_w,ncomm,infompi)
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
  !
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_2',1,zhook_handle)
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_5',0,zhook_handle)
  !
ELSEIF (nproc>1) THEN
  !
  pwork2(:,:,:) = 0.
  !
  idx_w = idx_w + 1
  !
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_2',1,zhook_handle)

!!$OMP PARALLEL DO PRIVATE(I,ZINTER,ICPT,J,INFOMPI,ISTATUS,ZHOOK_HANDLE_OMP)
  DO i=0,nproc-1
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_3',0,zhook_handle_omp)
    !
#ifdef SFX_MPI   
    xtime0 = mpi_wtime()
#endif    
    !
    IF (i/=npio) THEN
#ifdef SFX_MPI
      CALL mpi_recv(zinter,SIZE(zinter)*kind(zinter)/4,mpi_real,i,idx_w,ncomm,istatus,infompi)
#endif
    ELSE
      zinter(:,:,:) = zwork(:,:,:)
    ENDIF
!    !
#ifdef SFX_MPI    
    xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
    !
    xtime0 = mpi_wtime()
#endif     
    !    
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_3',1,zhook_handle_omp)
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_4',0,zhook_handle_omp)

    icpt = 0
    !
    DO j=1,SIZE(nindex)
      !
      IF ( nindex(j)==i ) THEN
        icpt = icpt + 1
        pwork2(j,:,:) = zinter(icpt,:,:)
      ENDIF
      !
    ENDDO
     !
#ifdef SFX_MPI    
    xtime_calc_write = xtime_calc_write + (mpi_wtime() - xtime0)
#endif      
     ! 
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_4',1,zhook_handle_omp)
  ENDDO
!!$OMP END PARALLEL DO
  !
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_5',0,zhook_handle)
  !
ELSE
  pwork2(:,:,:) = zwork(:,:,:)
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_2',1,zhook_handle)
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_5',0,zhook_handle)

ENDIF
!
IF (lhook) CALL dr_hook('GATHER_AND_WRITE_MPI_X3D0_5',1,zhook_handle)
!
!
END SUBROUTINE gather_and_write_mpi_x3d0
!
!**************************************************************************