source: NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90 @ 14349

   SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )
      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine
      TYPE(PTR_4d_/**/PRECISION),  DIMENSION(:), INTENT(inout) ::   ptab        ! pointer of arrays on which apply the b.c.
      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_nat      ! nature of array grid-points
      REAL(PRECISION),  DIMENSION(:), INTENT(in   ) ::   psgn        ! sign used across the north fold boundary
      INTEGER                       , INTENT(in   ) ::   kfld        ! number of pt3d arrays
      INTEGER ,             OPTIONAL, INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant)
      REAL(PRECISION),      OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries)
      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc
      !
      INTEGER  ::   ji, jj, jk, jl, jf, jn      ! dummy loop indices
      INTEGER  ::   ipk, ipl, ipf      ! dimension of the input array
      INTEGER  ::   ip0i, ip1i, im0i, im1i
      INTEGER  ::   ip0j, ip1j, im0j, im1j
      INTEGER  ::   ishti, ishtj, ishti2, ishtj2
      INTEGER  ::   ifill_nfd, icomm, ierr
      INTEGER  ::   idxs, idxr
      INTEGER, DIMENSION(4)  ::   isizei, ishtsi, ishtri, ishtpi
      INTEGER, DIMENSION(4)  ::   isizej, ishtsj, ishtrj, ishtpj
      INTEGER, DIMENSION(4)  ::   ifill, iszall, ishts, ishtr
      INTEGER, DIMENSION(4)  ::   ireq  ! mpi_request id
      REAL(PRECISION) ::   zland
      REAL(PRECISION), DIMENSION(:), ALLOCATABLE  ::   zsnd, zrcv          ! halos arrays
      LOGICAL, DIMENSION(4)  ::   llsend, llrecv
      LOGICAL  ::   ll_IdoNFold
      !!----------------------------------------------------------------------
      !
      ! ----------------------------------------- !
      !     1. local variables initialization     !
      ! ----------------------------------------- !
      !
      ipk = SIZE(ptab(1)%pt4d,3)
      ipl = SIZE(ptab(1)%pt4d,4)
      ipf = kfld
      !
      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
      !
      ! take care of optional parameters
      !
      zland = 0._wp                                     ! land filling value: zero by default
      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value
      !
      ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN   ! localy defined neighbourgs 
         llsend(1:4) = lsend(1:4)   ;   llrecv(1:4) = lrecv(1:4)
      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN
         WRITE(ctmp1,*) ' Routine ', cdname, '  is calling lbc_lnk with only one of the two arguments lsend or lrecv'
         CALL ctl_stop( 'STOP', ctmp1 )
      ELSE                                                  ! default neighbours
         llsend(1:4) = mpinei(1:4) >= 0
         llrecv(:) = llsend(:)
      END IF
      !
      ! define ifill: which method should be used to fill each parts (sides+corners) of the halos
      ! default definition
      DO jn = 1, 4
         IF(             llrecv(jn) ) THEN   ;   ifill(jn) = jpfillmpi    ! with an mpi communication
         ELSEIF(    l_SelfPerio(jn) ) THEN   ;   ifill(jn) = jpfillperio  ! with self-periodicity
         ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill(jn) = kfillmode    ! localy defined
         ELSE                                ;   ifill(jn) = jpfillcst    ! constant value (zland)
         END IF
      END DO
      ! north fold treatment
      ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing
      IF( ll_IdoNFold ) THEN
         ifill_nfd = ifill(jpno)             ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
         ifill( (/jpno/) ) = jpfillnothing   ! we do north fold -> do nothing for northern halo
      ENDIF
      
      ! We first define the localization and size of the parts of the array that will be sent (s), received (r)
      ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
      ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
      !                    !                       ________________________
      ip0i =          0    !          im0j = inner |__|__|__________|__|__|
      ip1i =      nn_hls   !   im1j = inner - halo |__|__|__________|__|__|
      im1i = Nie0-nn_hls   !                       |  |  |          |  |  |
      im0i = Nie0          !                       |  |  |          |  |  |
      ip0j =          0    !                       |  |  |          |  |  |
      ip1j =      nn_hls   !                       |__|__|__________|__|__|
      im1j = Nje0-nn_hls   !           ip1j = halo |__|__|__________|__|__|
      im0j = Nje0          !              ip0j = 0 |__|__|__________|__|__|
      !                    !                    ip0i ip1i        im1i im0i
      !
      !     sides:       west    east   south   north
      isizei(1:4) = (/ nn_hls, nn_hls,    jpi,    jpi /)   ! i- count
      isizej(1:4) = (/    jpj,    jpj, nn_hls, nn_hls /)   ! j- count
      ishtsi(1:4) = (/   ip1i,   im1i,   ip0i,   ip0i /)   ! i- shift send data
      ishtsj(1:4) = (/   ip0j,   ip0j,   ip1j,   im1j /)   ! j- shift send data
      ishtri(1:4) = (/   ip0i,   im0i,   ip0i,   ip0i /)   ! i- shift received data location
      ishtrj(1:4) = (/   ip0j,   ip0j,   ip0j,   im0j /)   ! j- shift received data location
      ishtpi(1:4) = (/   im1i,   ip1i,   ip0i,   ip0i /)   ! i- shift data used for periodicity
      ishtpj(1:4) = (/   ip0j,   ip0j,   im1j,   ip1j /)   ! j- shift data used for periodicity
      !
      ! -------------------------------- !
      !     2. Prepare MPI exchanges     !
      ! -------------------------------- !
      !
      ireq(:) = MPI_REQUEST_NULL
      iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
      ishts(1) = 0
      DO jn = 2,4
         ishts(jn) = ishts(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) )   ! with _alltoallv: in units of sendtype
      END DO
      ishtr(1) = 0
      DO jn = 2,4
         ishtr(jn) = ishtr(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) )   ! with _alltoallv: in units of sendtype
      END DO

      ! Allocate local temporary arrays to be sent/received.
      ALLOCATE( zsnd( SUM(iszall, mask = llsend) ), zrcv( SUM(iszall, mask = llrecv) ) )
      !
      ! -------------------------------------------------- !
      !     3. Do east and west MPI exchange if needed     !
      ! -------------------------------------------------- !
      !
      ! fill sending buffer with ARRAY_IN
      idxs = 1
      DO jn = 1, 2
         IF( llsend(jn) ) THEN
            ishti = ishtsi(jn)
            ishtj = ishtsj(jn)
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
               idxs = idxs + 1
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         END IF
      END DO
      !
#if ! defined key_mpi_off
      IF( ln_timing ) CALL tic_tac(.TRUE.)
      !
      icomm = mpi_comm_oce        ! shorter name
      ! non-blocking send of the western/eastern side using local temporary arrays
      jn = jpwe
      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 1, icomm, ireq(jn), ierr )
      jn = jpea
      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 2, icomm, ireq(jn), ierr )
      ! blocking receive of the western/eastern halo in local temporary arrays
      jn = jpwe
      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 2, icomm, MPI_STATUS_IGNORE, ierr )
      jn = jpea
      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 1, icomm, MPI_STATUS_IGNORE, ierr )
      !
      IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
      !
      ! ----------------------------------- !
      !     4. Fill east and west halos     !
      ! ----------------------------------- !
      !
      idxr = 1
      DO jn = 1, 2
         ishti = ishtri(jn)
         ishtj = ishtrj(jn)
         SELECT CASE ( ifill(jn) )
         CASE ( jpfillnothing )               ! no filling 
         CASE ( jpfillmpi   )                 ! fill with data received by MPI
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idxr)
               idxr = idxr + 1
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         CASE ( jpfillperio )                 ! use periodicity
            ishti2 = ishtpi(jn)
            ishtj2 = ishtpj(jn)
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         CASE ( jpfillcopy  )                 ! filling with inner domain values
            ishti2 = ishtsi(jn)
            ishtj2 = ishtsj(jn)
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         CASE ( jpfillcst   )                 ! filling with constant value
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         END SELECT
      END DO
      !
      ! ------------------------------- !
      !     5. north fold treatment     !
      ! ------------------------------- !
      !
      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
      !
      IF( ll_IdoNFold ) THEN
         IF( jpni == 1 )  THEN   ;   CALL lbc_nfd( ptab, cd_nat, psgn                  , ipf )   ! self NFold
         ELSE                    ;   CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ipf )   ! mpi  NFold
         ENDIF
      ENDIF
      !
      ! ---------------------------------------------------- !
      !     6. Do north and south MPI exchange if needed     !
      ! ---------------------------------------------------- !
      !
      DO jn = 3, 4
         IF( llsend(jn) ) THEN
            ishti = ishtsi(jn)
            ishtj = ishtsj(jn)
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
               idxs = idxs + 1
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         END IF
      END DO
      !
#if ! defined key_mpi_off
      IF( ln_timing ) CALL tic_tac(.TRUE.)
      !
      ! non-blocking send of the western/eastern side using local temporary arrays
      jn = jpso
      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 3, icomm, ireq(jn), ierr )
      jn = jpno
      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishts(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 4, icomm, ireq(jn), ierr )
      ! blocking receive of the western/eastern halo in local temporary arrays
      jn = jpso
      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 4, icomm, MPI_STATUS_IGNORE, ierr )
      jn = jpno
      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtr(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 3, icomm, MPI_STATUS_IGNORE, ierr )
      !
      IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
      !
      ! ------------------------------------- !
      !     7. Fill south and north halos     !
      ! ------------------------------------- !
      !
      DO jn = 3, 4
         ishti = ishtri(jn)
         ishtj = ishtrj(jn)
         SELECT CASE ( ifill(jn) )
         CASE ( jpfillnothing )               ! no filling 
         CASE ( jpfillmpi   )                 ! fill with data received by MPI
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idxr)
               idxr = idxr + 1
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         CASE ( jpfillperio )                 ! use periodicity
            ishti2 = ishtpi(jn)
            ishtj2 = ishtpj(jn)
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         CASE ( jpfillcopy  )                 ! filling with inner domain values
            ishti2 = ishtsi(jn)
            ishtj2 = ishtsj(jn)
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         CASE ( jpfillcst   )                 ! filling with constant value
            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
         END SELECT
      END DO
      !
      ! -------------------------------------------- !
      !     8. deallocate local temporary arrays     !
      ! -------------------------------------------- !
      !
      CALL mpi_waitall(4, ireq, MPI_STATUSES_IGNORE, ierr)
      DEALLOCATE( zsnd, zrcv )
      !
   END SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION