Changeset 11192 for NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/mpp_lnk_generic.h90
- Timestamp:
- 2019-06-27T12:40:32+02:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/mpp_lnk_generic.h90
r10542 r11192 46 46 47 47 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval )49 INTEGER 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval ) 49 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 50 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval )51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval ) 52 52 #endif 53 53 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 CHARACTER(len=*) 55 CHARACTER(len=1) 56 REAL(wp) 57 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only58 REAL(wp) , OPTIONAL , INTENT(in ) :: pval! background value (used at closed boundaries)59 ! 60 INTEGER :: ji, jj, jk, jl, jh, jf! dummy loop indices54 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 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 58 REAL(wp), OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 59 ! 60 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 61 61 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_isend62 INTEGER :: isize, ishift, ishift2 ! local integers 63 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 64 64 INTEGER :: ierr 65 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 65 66 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 67 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 68 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 69 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 70 LOGICAL :: llcom_we, llcom_ea, llcom_no, llcom_so ! communication done or not 71 LOGICAL :: lldo_nfd ! do north pole folding 69 72 !!---------------------------------------------------------------------- 73 ! 74 ! ----------------------------------------- ! 75 ! 0. local variables initialization ! 76 ! ----------------------------------------- ! 70 77 ! 71 78 ipk = K_SIZE(ptab) ! 3rd dimension … … 75 82 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 76 83 ! 77 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 78 ELSE ; zland = 0._wp ! zero by default 79 ENDIF 80 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 84 llcom_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 85 llcom_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 86 llcom_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 87 llcom_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 88 89 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 90 91 zland = 0._wp ! land filling value: zero by default 92 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 93 94 ! define the method we will use to fill the halos in each direction 95 IF( llcom_we ) THEN ; ifill_we = jpfillmpi 96 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 97 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 98 ELSE ; ifill_we = jpfillcst 99 END IF 100 ! 101 IF( llcom_ea ) THEN ; ifill_ea = jpfillmpi 102 ELSE ; ifill_ea = ifill_we 103 END IF 104 ! 105 IF( llcom_so ) THEN ; ifill_so = jpfillmpi 106 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 107 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 108 ELSE ; ifill_so = jpfillcst 109 END IF 110 ! 111 IF( llcom_no ) THEN ; ifill_no = jpfillmpi 112 ELSE ; ifill_no = ifill_so ! warning will be potentially changed if lldo_nfd = T 113 END IF 114 ! 115 #if defined PRINT_CAUTION 116 ! 117 ! ================================================================================== ! 118 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 119 ! ================================================================================== ! 120 ! 121 #endif 122 ! 123 ! -------------------------------------------------- ! 124 ! 1. Do east and west MPI exchange if needed ! 125 ! -------------------------------------------------- ! 126 ! 127 ! these echanges are made for jj = nn_hls+1 to jpj-nn_hls 128 isize = nn_hls * ( jpj - 2*nn_hls ) * ipk * ipl * ipf 129 130 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 131 IF( ifill_we == jpfillmpi ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 132 ! 133 ALLOCATE( zsnd_we(nn_hls,jpj-2*nn_hls,ipk,ipl,ipf), zrcv_we(nn_hls,jpj-2*nn_hls,ipk,ipl,ipf) ) 134 ishift = nn_hls 135 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 136 zsnd_we(ji,jj-nn_hls,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 137 END DO ; END DO ; END DO ; END DO ; END DO 138 ENDIF 139 ! 140 IF( ifill_ea == jpfillmpi ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 141 ! 142 ALLOCATE( zsnd_ea(nn_hls,jpj-2*nn_hls,ipk,ipl,ipf), zrcv_ea(nn_hls,jpj-2*nn_hls,ipk,ipl,ipf) ) 143 ishift = jpi - 2 * nn_hls 144 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 145 zsnd_ea(ji,jj-nn_hls,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 146 END DO ; END DO ; END DO ; END DO ; END DO 147 ENDIF 148 ! 149 IF( ln_timing ) CALL tic_tac(.TRUE.) 150 ! 151 ! non-blocking send of the western/eastern side using local temporary arrays 152 IF( ifill_we == jpfillmpi ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 153 IF( ifill_ea == jpfillmpi ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 154 ! blocking receive of the western/eastern halo in local temporary arrays 155 IF( ifill_we == jpfillmpi ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 156 IF( ifill_ea == jpfillmpi ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 157 ! 158 IF( ln_timing ) CALL tic_tac(.FALSE.) 159 ! 160 ! 161 ! ----------------------------------- ! 162 ! 2. Fill east and west halos ! 163 ! ----------------------------------- ! 164 ! 165 ! 2.1 fill weastern halo 166 ! ---------------------- 167 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 168 SELECT CASE ( ifill_we ) 169 CASE ( jpfillnothing ) ! no filling 170 CASE ( jpfillmpi ) ! use data received by MPI 171 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 172 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj-nn_hls,jk,jl,jf) ! 1 -> nn_hls 173 END DO; END DO ; END DO ; END DO ; END DO 174 CASE ( jpfillperio ) ! use east-weast periodicity 175 ishift2 = jpi - 2 * nn_hls 176 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 177 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 178 END DO; END DO ; END DO ; END DO ; END DO 179 CASE ( jpfillcopy ) ! filling with inner domain values 180 DO jf = 1, ipf ! number of arrays to be treated 181 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 182 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 183 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 184 END DO ; END DO ; END DO ; END DO 104 185 ENDIF 105 186 END DO 106 ! 107 ENDIF 108 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 187 CASE ( jpfillcst ) ! filling with constant value 188 DO jf = 1, ipf ! number of arrays to be treated 189 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 190 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 191 ARRAY_IN(ji,jj,jk,jl,jf) = zland 192 END DO; END DO ; END DO ; END DO 193 ENDIF 151 194 END DO 152 195 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 ) 196 ! 197 ! 2.2 fill eastern halo 198 ! --------------------- 199 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 200 SELECT CASE ( ifill_ea ) 201 CASE ( jpfillnothing ) ! no filling 202 CASE ( jpfillmpi ) ! use data received by MPI 203 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 204 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj-nn_hls,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 205 END DO ; END DO ; END DO ; END DO ; END DO 206 CASE ( jpfillperio ) ! use east-weast periodicity 207 ishift2 = nn_hls 208 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 209 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 210 END DO ; END DO ; END DO ; END DO ; END DO 211 CASE ( jpfillcopy ) ! filling with inner domain values 212 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 213 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 214 END DO ; END DO ; END DO ; END DO ; END DO 215 CASE ( jpfillcst ) ! filling with constant value 216 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls+1, jpj-nn_hls ; DO ji = 1, nn_hls 217 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 218 END DO; END DO ; END DO ; END DO ; END DO 174 219 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 220 ! 217 221 ! ------------------------------- ! 218 222 ! 3. north fold treatment ! 219 223 ! ------------------------------- ! 224 ! 220 225 ! 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 226 ! 227 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 222 228 ! 223 229 SELECT CASE ( jpni ) … … 226 232 END SELECT 227 233 ! 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 234 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 235 ! 236 ENDIF 237 ! 238 ! ---------------------------------------------------- ! 239 ! 4. Do north and south MPI exchange if needed ! 240 ! ---------------------------------------------------- ! 241 ! 242 isize = jpi * nn_hls * ipk * ipl * ipf 243 244 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 245 IF( ifill_so == jpfillmpi ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 246 ! 247 ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf), zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 248 ishift = nn_hls 249 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 250 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 251 END DO ; END DO ; END DO ; END DO ; END DO 252 ENDIF 253 ! 254 IF( ifill_no == jpfillmpi ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 255 ! 256 ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf), zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 257 ishift = jpj - 2 * nn_hls 258 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 259 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 260 END DO ; END DO ; END DO ; END DO ; END DO 261 ENDIF 262 ! 263 IF( ln_timing ) CALL tic_tac(.TRUE.) 264 ! 265 ! non-blocking send of the southern/northern side 266 IF( ifill_so == jpfillmpi ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 267 IF( ifill_no == jpfillmpi ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 268 ! blocking receive of the southern/northern halo 269 IF( ifill_so == jpfillmpi ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 270 IF( ifill_no == jpfillmpi ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 271 ! 272 IF( ln_timing ) CALL tic_tac(.FALSE.) 273 ! 274 ! ------------------------------------- ! 275 ! 5. Fill south and north halos ! 276 ! ------------------------------------- ! 277 ! 278 ! 5.1 fill southern halo 279 ! ---------------------- 280 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 281 SELECT CASE ( ifill_so ) 282 CASE ( jpfillnothing ) ! no filling 283 CASE ( jpfillmpi ) ! use data received by MPI 284 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 285 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 286 END DO; END DO ; END DO ; END DO ; END DO 287 CASE ( jpfillperio ) ! use north-south periodicity 288 ishift2 = jpj - 2 * nn_hls 289 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 290 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 291 END DO; END DO ; END DO ; END DO ; END DO 292 CASE ( jpfillcopy ) ! filling with inner domain values 293 DO jf = 1, ipf ! number of arrays to be treated 294 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 295 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 296 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 297 END DO ; END DO ; END DO ; END DO 298 ENDIF 249 299 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 300 CASE ( jpfillcst ) ! filling with constant value 301 DO jf = 1, ipf ! number of arrays to be treated 302 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 303 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 304 ARRAY_IN(ji,jj,jk,jl,jf) = zland 305 END DO; END DO ; END DO ; END DO 306 ENDIF 272 307 END DO 273 308 END SELECT 274 309 ! 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 ) 310 ! 5.2 fill northern halo 311 ! ---------------------- 312 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 313 SELECT CASE ( ifill_no ) 314 CASE ( jpfillnothing ) ! no filling 315 CASE ( jpfillmpi ) ! use data received by MPI 316 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 317 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 318 END DO ; END DO ; END DO ; END DO ; END DO 319 CASE ( jpfillperio ) ! use north-south periodicity 320 ishift2 = nn_hls 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,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 323 END DO; END DO ; END DO ; END DO ; END DO 324 CASE ( jpfillcopy ) ! filling with inner domain values 325 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 326 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 327 END DO; END DO ; END DO ; END DO ; END DO 328 CASE ( jpfillcst ) ! filling with constant value 329 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 330 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 331 END DO; END DO ; END DO ; END DO ; END DO 296 332 END SELECT 297 333 ! 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 ) 334 ! -------------------------------------------- ! 335 ! 6. deallocate local temporary arrays ! 336 ! -------------------------------------------- ! 337 ! 338 IF( ifill_we == jpfillmpi ) THEN 339 CALL mpi_wait(ireq_we, istat, ierr ) 340 DEALLOCATE( zsnd_we, zrcv_we ) 341 ENDIF 342 IF( ifill_ea == jpfillmpi ) THEN 343 CALL mpi_wait(ireq_ea, istat, ierr ) 344 DEALLOCATE( zsnd_ea, zrcv_ea ) 345 ENDIF 346 IF( ifill_so == jpfillmpi ) THEN 347 CALL mpi_wait(ireq_so, istat, ierr ) 348 DEALLOCATE( zsnd_so, zrcv_so ) 349 ENDIF 350 IF( ifill_no == jpfillmpi ) THEN 351 CALL mpi_wait(ireq_no, istat, ierr ) 352 DEALLOCATE( zsnd_no, zrcv_no ) 353 ENDIF 337 354 ! 338 355 END SUBROUTINE ROUTINE_LNK
Note: See TracChangeset
for help on using the changeset viewer.
