# define NAT_IN(k) cd_nat(k) # define SGN_IN(k) psgn(k) # define F_SIZE(ptab) kfld # define OPT_K(k) ,ipf # if defined DIM_2d # if defined SINGLE_PRECISION # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) # else # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) # endif # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) # define K_SIZE(ptab) 1 # define L_SIZE(ptab) 1 # endif # if defined DIM_3d # if defined SINGLE_PRECISION # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) # else # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) # endif # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) # define L_SIZE(ptab) 1 # endif # if defined DIM_4d # if defined SINGLE_PRECISION # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) # else # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) # endif # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) # endif # if defined SINGLE_PRECISION # define PRECISION sp # define MPI_TYPE MPI_REAL # else # define PRECISION dp # define MPI_TYPE MPI_DOUBLE_PRECISION # endif SUBROUTINE ROUTINE_NC( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 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 LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil ! 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 :: iszs, iszr INTEGER :: ierr INTEGER :: idx INTEGER :: impi_nc INTEGER, DIMENSION(4) :: iwewe, issnn INTEGER, DIMENSION(8) :: isizei, ishtsi, ishtri, ishtpi INTEGER, DIMENSION(8) :: isizej, ishtsj, ishtrj, ishtpj INTEGER, DIMENSION(8) :: ifill, iszall INTEGER, DIMENSION(:), ALLOCATABLE :: icounts, icountr ! number of elements to be sent/received INTEGER, DIMENSION(:), ALLOCATABLE :: idispls, idisplr ! displacement in halos arrays LOGICAL, DIMENSION(8) :: llsend, llrecv REAL(PRECISION) :: zland REAL(PRECISION), DIMENSION(:), ALLOCATABLE :: zsnd, zrcv ! halos arrays LOGICAL :: llncall ! default: 9-point stencil LOGICAL :: ll_IdoNFold !!---------------------------------------------------------------------- #if defined PRINT_CAUTION ! ! ================================================================================== ! ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! ! ================================================================================== ! ! #endif ! ! ----------------------------------------- ! ! 1. local variables initialization ! ! ----------------------------------------- ! ! ipk = K_SIZE(ptab) ! 3rd dimension ipl = L_SIZE(ptab) ! 4th - ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) ! IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) ! ! take care of optional parameters ! llncall = .TRUE. IF( PRESENT(ncsten) ) llncall = ncsten ! impi_nc = mpi_nc_com4 IF(llncall) impi_nc = mpi_nc_com8 ! 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 CALL ctl_stop( 'STOP', 'mpp_nc_generic+BDY not yet implemented') !!$ ---> llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) ??? 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(:) = mpinei(:) >= 0 IF( .NOT. llncall ) llsend(5:8) = .FALSE. ! exclude corners 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, 8 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 ! take care of "indirect self-periodicity" for the corners DO jn = 5, 8 IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later END DO ! north fold treatment ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing IF( ll_IdoNFold ) ifill( (/jpno,jpnw,jpne/) ) = jpfillnothing ! we do north fold -> do nothing for northern halos ! ! ________________________ 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 ! iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea isizei(1:4) = (/ nn_hls, nn_hls, Ni_0, Ni_0 /) ; isizei(5:8) = nn_hls ! i- count isizej(1:4) = (/ Nj_0, Nj_0, nn_hls, nn_hls /) ; isizej(5:8) = nn_hls ! j- count ishtsi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtsi(5:8) = ishtsi( iwewe ) ! i- shift send data ishtsj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtsj(5:8) = ishtsj( issnn ) ! j- shift send data ishtri(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtri(5:8) = ishtri( iwewe ) ! i- shift received data location ishtrj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtrj(5:8) = ishtrj( issnn ) ! j- shift received data location ishtpi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtpi(5:8) = ishtpi( iwewe ) ! i- shift data used for periodicity ishtpj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtpj(5:8) = ishtpj( issnn ) ! j- shift data used for periodicity ! ! -------------------------------- ! ! 2. Prepare MPI exchanges ! ! -------------------------------- ! ! ! Allocate local temporary arrays to be sent/received. iszs = COUNT( llsend ) iszr = COUNT( llrecv ) ALLOCATE( icounts(iszs), icountr(iszr), idispls(iszs), idisplr(iszr) ) ! ok if iszs = 0 or iszr = 0 iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf icounts(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. icountr(:) = PACK( iszall, mask = llrecv ) idispls(1) = 0 DO jn = 2,iszs idispls(jn) = idispls(jn-1) + icounts(jn-1) ! with _alltoallv: in units of sendtype END DO idisplr(1) = 0 DO jn = 2,iszr idisplr(jn) = idisplr(jn-1) + icountr(jn-1) ! with _alltoallv: in units of sendtype END DO ALLOCATE( zsnd(SUM(icounts)), zrcv(SUM(icountr)) ) ! fill sending buffer with ARRAY_IN idx = 1 DO jn = 1, 8 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(idx) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) idx = idx + 1 END DO ; END DO ; END DO ; END DO ; END DO END IF END DO ! ! ------------------------------------------------ ! ! 3. Do all MPI exchanges in 1 unique call ! ! ------------------------------------------------ ! ! IF( ln_timing ) CALL tic_tac(.TRUE.) CALL mpi_neighbor_alltoallv (zsnd, icounts, idispls, MPI_TYPE, zrcv, icountr, idisplr, MPI_TYPE, impi_nc, ierr) IF( ln_timing ) CALL tic_tac(.FALSE.) ! ! ------------------------- ! ! 4. Fill all halos ! ! ------------------------- ! ! idx = 1 DO jn = 1, 8 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) ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idx) idx = idx + 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) ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 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) ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 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) ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland END DO ; END DO ; END DO ; END DO ; END DO END SELECT END DO DEALLOCATE( icounts, icountr, idispls, idisplr, zsnd, zrcv ) ! potential "indirect self-periodicity" for the corners DO jn = 5, 8 IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition ishti = ishtri(jn) ishtj = ishtrj(jn) ishti2 = ishtpi(jn) ! use i- shift periodicity ishtj2 = ishtrj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) END DO ; END DO ; END DO ; END DO ; END DO ENDIF IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition ishti = ishtri(jn) ishtj = ishtrj(jn) ishti2 = ishtri(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done ishtj2 = ishtpj(jn) ! use j- shift periodicity DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) END DO ; END DO ; END DO ; END DO ; END DO ENDIF END DO ! ! ------------------------------- ! ! 5. north fold treatment ! ! ------------------------------- ! ! IF( ll_IdoNFold ) THEN IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! self NFold ELSE ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill(jpno), zland OPT_K(:) ) ! mpi NFold ENDIF ENDIF END SUBROUTINE ROUTINE_NC #undef PRECISION #undef ARRAY_TYPE #undef NAT_IN #undef SGN_IN #undef ARRAY_IN #undef K_SIZE #undef L_SIZE #undef F_SIZE #undef OPT_K #undef MPI_TYPE