- Timestamp:
- 2020-09-14T17:40:34+02:00 (4 years ago)
- Location:
- NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/LBC/mpp_lnk_generic.h90 (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 9 # SETTE 10 ^/utils/CI/sette@13382 sette
-
- Property svn:externals
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/LBC/mpp_lnk_generic.h90
r10542 r13463 5 5 # define OPT_K(k) ,ipf 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 23 35 # endif 24 36 #else 25 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 37 # if defined SINGLE_PRECISION 38 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 39 # else 40 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 41 # endif 26 42 # define NAT_IN(k) cd_nat 27 43 # define SGN_IN(k) psgn … … 45 61 #endif 46 62 63 # if defined SINGLE_PRECISION 64 # define PRECISION sp 65 # define SENDROUTINE mppsend_sp 66 # define RECVROUTINE mpprecv_sp 67 # else 68 # define PRECISION dp 69 # define SENDROUTINE mppsend_dp 70 # define RECVROUTINE mpprecv_dp 71 # endif 72 47 73 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval)49 INTEGER 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 76 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval)77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv ) 52 78 #endif 53 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 58 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 59 ! 60 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices 80 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 ! 87 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 61 88 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 62 INTEGER :: i migr, iihom, ijhom! local integers63 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend89 INTEGER :: isize, ishift, ishift2 ! local integers 90 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 64 91 INTEGER :: ierr 92 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 65 93 REAL(wp) :: zland 66 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 67 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos 68 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos 94 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 95 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 96 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 97 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 98 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 99 LOGICAL :: lldo_nfd ! do north pole folding 69 100 !!---------------------------------------------------------------------- 101 ! 102 ! ----------------------------------------- ! 103 ! 0. local variables initialization ! 104 ! ----------------------------------------- ! 70 105 ! 71 106 ipk = K_SIZE(ptab) ! 3rd dimension … … 75 110 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 76 111 ! 77 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 78 ELSE ; zland = 0._wp ! zero by default 79 ENDIF 112 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 113 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 114 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 115 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 116 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 117 WRITE(ctmp2,*) ' ========== ' 118 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 119 ELSE ! send and receive with every neighbour 120 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 121 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 122 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 123 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 124 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 125 END IF 126 127 128 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 80 129 81 ! ------------------------------- ! 82 ! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible 83 ! ------------------------------- ! 84 ! 85 IF( .NOT. PRESENT( cd_mpp ) ) THEN !== standard close or cyclic treatment ==! 86 ! 87 DO jf = 1, ipf ! number of arrays to be treated 88 ! 89 ! ! East-West boundaries 90 IF( l_Iperio ) THEN !* cyclic 91 ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 92 ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf) 93 ELSE !* closed 94 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :nn_hls,:,:,:,jf) = zland ! east except F-point 95 ARRAY_IN(nlci-nn_hls+1:jpi ,:,:,:,jf) = zland ! west 96 ENDIF 97 ! ! North-South boundaries 98 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 99 ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 100 ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf) 101 ELSE !* closed 102 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :nn_hls,:,:,jf) = zland ! south except F-point 103 ARRAY_IN(:,nlcj-nn_hls+1:jpj ,:,:,jf) = zland ! north 104 ENDIF 105 END DO 106 ! 107 ENDIF 130 zland = 0._wp ! land filling value: zero by default 131 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 108 132 109 ! ------------------------------- ! 110 ! East and west exchange ! 111 ! ------------------------------- ! 112 ! we play with the neigbours AND the row number because of the periodicity 113 ! 114 IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 115 IF( nbondi == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 116 ! 117 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 118 CASE ( -1 ) 119 iihom = nlci-nreci 120 DO jf = 1, ipf 121 DO jl = 1, ipl 122 DO jk = 1, ipk 123 DO jh = 1, nn_hls 124 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 125 END DO 126 END DO 127 END DO 128 END DO 129 CASE ( 0 ) 130 iihom = nlci-nreci 131 DO jf = 1, ipf 132 DO jl = 1, ipl 133 DO jk = 1, ipk 134 DO jh = 1, nn_hls 135 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 136 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 137 END DO 138 END DO 139 END DO 140 END DO 141 CASE ( 1 ) 142 iihom = nlci-nreci 143 DO jf = 1, ipf 144 DO jl = 1, ipl 145 DO jk = 1, ipk 146 DO jh = 1, nn_hls 147 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 148 END DO 149 END DO 150 END DO 151 END DO 133 ! define the method we will use to fill the halos in each direction 134 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 135 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 136 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 137 ELSE ; ifill_we = jpfillcst 138 END IF 139 ! 140 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 141 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 142 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 143 ELSE ; ifill_ea = jpfillcst 144 END IF 145 ! 146 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 147 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 148 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 149 ELSE ; ifill_so = jpfillcst 150 END IF 151 ! 152 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 153 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 154 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 155 ELSE ; ifill_no = jpfillcst 156 END IF 157 ! 158 #if defined PRINT_CAUTION 159 ! 160 ! ================================================================================== ! 161 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 162 ! ================================================================================== ! 163 ! 164 #endif 165 ! 166 ! -------------------------------------------------- ! 167 ! 1. Do east and west MPI exchange if needed ! 168 ! -------------------------------------------------- ! 169 ! 170 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 171 isize = nn_hls * jpj * ipk * ipl * ipf 172 ! 173 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 174 IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) ) 175 IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) ) 176 IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) ) 177 IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) ) 178 ! 179 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 180 ishift = nn_hls 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 182 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 183 END DO ; END DO ; END DO ; END DO ; END DO 184 ENDIF 185 ! 186 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 187 ishift = jpi - 2 * nn_hls 188 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 189 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 190 END DO ; END DO ; END DO ; END DO ; END DO 191 ENDIF 192 ! 193 IF( ln_timing ) CALL tic_tac(.TRUE.) 194 ! 195 ! non-blocking send of the western/eastern side using local temporary arrays 196 IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 197 IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 198 ! blocking receive of the western/eastern halo in local temporary arrays 199 IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 200 IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 201 ! 202 IF( ln_timing ) CALL tic_tac(.FALSE.) 203 ! 204 ! 205 ! ----------------------------------- ! 206 ! 2. Fill east and west halos ! 207 ! ----------------------------------- ! 208 ! 209 ! 2.1 fill weastern halo 210 ! ---------------------- 211 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 212 SELECT CASE ( ifill_we ) 213 CASE ( jpfillnothing ) ! no filling 214 CASE ( jpfillmpi ) ! use data received by MPI 215 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 216 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls 217 END DO ; END DO ; END DO ; END DO ; END DO 218 CASE ( jpfillperio ) ! use east-weast periodicity 219 ishift2 = jpi - 2 * nn_hls 220 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 221 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 222 END DO ; END DO ; END DO ; END DO ; END DO 223 CASE ( jpfillcopy ) ! filling with inner domain values 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 225 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 226 END DO ; END DO ; END DO ; END DO ; END DO 227 CASE ( jpfillcst ) ! filling with constant value 228 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 229 ARRAY_IN(ji,jj,jk,jl,jf) = zland 230 END DO ; END DO ; END DO ; END DO ; END DO 152 231 END SELECT 153 ! ! Migrations 154 imigr = nn_hls * jpj * ipk * ipl * ipf 155 ! 156 IF( ln_timing ) CALL tic_tac(.TRUE.) 157 ! 158 SELECT CASE ( nbondi ) 159 CASE ( -1 ) 160 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 161 CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 162 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 163 CASE ( 0 ) 164 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 165 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 166 CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 167 CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 168 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 169 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 170 CASE ( 1 ) 171 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 172 CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 173 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 232 ! 233 ! 2.2 fill eastern halo 234 ! --------------------- 235 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 236 SELECT CASE ( ifill_ea ) 237 CASE ( jpfillnothing ) ! no filling 238 CASE ( jpfillmpi ) ! use data received by MPI 239 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 240 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 241 END DO ; END DO ; END DO ; END DO ; END DO 242 CASE ( jpfillperio ) ! use east-weast periodicity 243 ishift2 = nn_hls 244 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 245 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 246 END DO ; END DO ; END DO ; END DO ; END DO 247 CASE ( jpfillcopy ) ! filling with inner domain values 248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 249 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 250 END DO ; END DO ; END DO ; END DO ; END DO 251 CASE ( jpfillcst ) ! filling with constant value 252 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 253 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 254 END DO ; END DO ; END DO ; END DO ; END DO 174 255 END SELECT 175 !176 IF( ln_timing ) CALL tic_tac(.FALSE.)177 !178 ! ! Write Dirichlet lateral conditions179 iihom = nlci-nn_hls180 !181 SELECT CASE ( nbondi )182 CASE ( -1 )183 DO jf = 1, ipf184 DO jl = 1, ipl185 DO jk = 1, ipk186 DO jh = 1, nn_hls187 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)188 END DO189 END DO190 END DO191 END DO192 CASE ( 0 )193 DO jf = 1, ipf194 DO jl = 1, ipl195 DO jk = 1, ipk196 DO jh = 1, nn_hls197 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)198 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)199 END DO200 END DO201 END DO202 END DO203 CASE ( 1 )204 DO jf = 1, ipf205 DO jl = 1, ipl206 DO jk = 1, ipk207 DO jh = 1, nn_hls208 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)209 END DO210 END DO211 END DO212 END DO213 END SELECT214 !215 IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )216 256 ! 217 257 ! ------------------------------- ! 218 258 ! 3. north fold treatment ! 219 259 ! ------------------------------- ! 260 ! 220 261 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 221 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 262 ! 263 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 222 264 ! 223 265 SELECT CASE ( jpni ) 224 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp225 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.266 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 267 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 226 268 END SELECT 227 269 ! 228 ENDIF 229 ! 230 ! ------------------------------- ! 231 ! 4. North and south directions ! 232 ! ------------------------------- ! 233 ! always closed : we play only with the neigbours 234 ! 235 IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 236 IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 237 ! 238 SELECT CASE ( nbondj ) 239 CASE ( -1 ) 240 ijhom = nlcj-nrecj 241 DO jf = 1, ipf 242 DO jl = 1, ipl 243 DO jk = 1, ipk 244 DO jh = 1, nn_hls 245 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 246 END DO 247 END DO 248 END DO 249 END DO 250 CASE ( 0 ) 251 ijhom = nlcj-nrecj 252 DO jf = 1, ipf 253 DO jl = 1, ipl 254 DO jk = 1, ipk 255 DO jh = 1, nn_hls 256 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 257 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 258 END DO 259 END DO 260 END DO 261 END DO 262 CASE ( 1 ) 263 ijhom = nlcj-nrecj 264 DO jf = 1, ipf 265 DO jl = 1, ipl 266 DO jk = 1, ipk 267 DO jh = 1, nn_hls 268 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 269 END DO 270 END DO 271 END DO 272 END DO 270 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 271 ! 272 ENDIF 273 ! 274 ! ---------------------------------------------------- ! 275 ! 4. Do north and south MPI exchange if needed ! 276 ! ---------------------------------------------------- ! 277 ! 278 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) ) 279 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) ) 280 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 281 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 282 ! 283 isize = jpi * nn_hls * ipk * ipl * ipf 284 285 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 286 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 287 ishift = nn_hls 288 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 289 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 290 END DO ; END DO ; END DO ; END DO ; END DO 291 ENDIF 292 ! 293 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 294 ishift = jpj - 2 * nn_hls 295 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 296 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 297 END DO ; END DO ; END DO ; END DO ; END DO 298 ENDIF 299 ! 300 IF( ln_timing ) CALL tic_tac(.TRUE.) 301 ! 302 ! non-blocking send of the southern/northern side 303 IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 304 IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 305 ! blocking receive of the southern/northern halo 306 IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 307 IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 308 ! 309 IF( ln_timing ) CALL tic_tac(.FALSE.) 310 ! 311 ! ------------------------------------- ! 312 ! 5. Fill south and north halos ! 313 ! ------------------------------------- ! 314 ! 315 ! 5.1 fill southern halo 316 ! ---------------------- 317 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 318 SELECT CASE ( ifill_so ) 319 CASE ( jpfillnothing ) ! no filling 320 CASE ( jpfillmpi ) ! use data received by MPI 321 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 322 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 323 END DO ; END DO ; END DO ; END DO ; END DO 324 CASE ( jpfillperio ) ! use north-south periodicity 325 ishift2 = jpj - 2 * nn_hls 326 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 327 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 328 END DO ; END DO ; END DO ; END DO ; END DO 329 CASE ( jpfillcopy ) ! filling with inner domain values 330 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 331 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 332 END DO ; END DO ; END DO ; END DO ; END DO 333 CASE ( jpfillcst ) ! filling with constant value 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 335 ARRAY_IN(ji,jj,jk,jl,jf) = zland 336 END DO ; END DO ; END DO ; END DO ; END DO 273 337 END SELECT 274 338 ! 275 ! ! Migrations 276 imigr = nn_hls * jpi * ipk * ipl * ipf 277 ! 278 IF( ln_timing ) CALL tic_tac(.TRUE.) 279 ! 280 SELECT CASE ( nbondj ) 281 CASE ( -1 ) 282 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 283 CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 284 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 285 CASE ( 0 ) 286 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 287 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 288 CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 289 CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 290 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 291 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 292 CASE ( 1 ) 293 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 294 CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 295 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 339 ! 5.2 fill northern halo 340 ! ---------------------- 341 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 342 SELECT CASE ( ifill_no ) 343 CASE ( jpfillnothing ) ! no filling 344 CASE ( jpfillmpi ) ! use data received by MPI 345 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 346 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 347 END DO ; END DO ; END DO ; END DO ; END DO 348 CASE ( jpfillperio ) ! use north-south periodicity 349 ishift2 = nn_hls 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 352 END DO ; END DO ; END DO ; END DO ; END DO 353 CASE ( jpfillcopy ) ! filling with inner domain values 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 356 END DO ; END DO ; END DO ; END DO ; END DO 357 CASE ( jpfillcst ) ! filling with constant value 358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 359 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 360 END DO ; END DO ; END DO ; END DO ; END DO 296 361 END SELECT 297 362 ! 298 IF( ln_timing ) CALL tic_tac(.FALSE.) 299 ! ! Write Dirichlet lateral conditions 300 ijhom = nlcj-nn_hls 301 ! 302 SELECT CASE ( nbondj ) 303 CASE ( -1 ) 304 DO jf = 1, ipf 305 DO jl = 1, ipl 306 DO jk = 1, ipk 307 DO jh = 1, nn_hls 308 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 309 END DO 310 END DO 311 END DO 312 END DO 313 CASE ( 0 ) 314 DO jf = 1, ipf 315 DO jl = 1, ipl 316 DO jk = 1, ipk 317 DO jh = 1, nn_hls 318 ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 319 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 320 END DO 321 END DO 322 END DO 323 END DO 324 CASE ( 1 ) 325 DO jf = 1, ipf 326 DO jl = 1, ipl 327 DO jk = 1, ipk 328 DO jh = 1, nn_hls 329 ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 330 END DO 331 END DO 332 END DO 333 END DO 334 END SELECT 335 ! 336 IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 363 ! -------------------------------------------- ! 364 ! 6. deallocate local temporary arrays ! 365 ! -------------------------------------------- ! 366 ! 367 IF( llsend_we ) THEN 368 CALL mpi_wait(ireq_we, istat, ierr ) 369 DEALLOCATE( zsnd_we ) 370 ENDIF 371 IF( llsend_ea ) THEN 372 CALL mpi_wait(ireq_ea, istat, ierr ) 373 DEALLOCATE( zsnd_ea ) 374 ENDIF 375 IF( llsend_so ) THEN 376 CALL mpi_wait(ireq_so, istat, ierr ) 377 DEALLOCATE( zsnd_so ) 378 ENDIF 379 IF( llsend_no ) THEN 380 CALL mpi_wait(ireq_no, istat, ierr ) 381 DEALLOCATE( zsnd_no ) 382 ENDIF 383 ! 384 IF( llrecv_we ) DEALLOCATE( zrcv_we ) 385 IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) 386 IF( llrecv_so ) DEALLOCATE( zrcv_so ) 387 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 337 388 ! 338 389 END SUBROUTINE ROUTINE_LNK 339 390 #undef PRECISION 391 #undef SENDROUTINE 392 #undef RECVROUTINE 340 393 #undef ARRAY_TYPE 341 394 #undef NAT_IN
Note: See TracChangeset
for help on using the changeset viewer.
