- Timestamp:
- 2019-02-14T14:11:43+01:00 (5 years ago)
- Location:
- NEMO/branches/2019/fix_ticket2238_solution2
- Files:
-
- 1 edited
- 1 copied
-
. (copied) (copied from NEMO/trunk)
-
src/OCE/LBC/lib_mpp.F90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/fix_ticket2238_solution2/src/OCE/LBC/lib_mpp.F90
r10538 r10679 41 41 !! mynode : indentify the processor unit 42 42 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)44 43 !! mpprecv : 45 44 !! mppsend : … … 54 53 !! mppstop : 55 54 !! mpp_ini_north : initialisation of north fold 56 !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs57 55 !!---------------------------------------------------------------------- 58 56 USE dom_oce ! ocean space and time domain … … 80 78 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 81 79 PUBLIC mpp_ini_north 82 PUBLIC mpp_lnk_2d_icb83 PUBLIC mpp_lbc_north_icb84 80 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 85 81 PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv … … 1185 1181 ! 1186 1182 END SUBROUTINE DDPDD_MPI 1187 1188 1189 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1190 !!---------------------------------------------------------------------1191 !! *** routine mpp_lbc_north_icb ***1192 !!1193 !! ** Purpose : Ensure proper north fold horizontal bondary condition1194 !! in mpp configuration in case of jpn1 > 1 and for 2d1195 !! array with outer extra halo1196 !!1197 !! ** Method : North fold condition and mpp with more than one proc1198 !! in i-direction require a specific treatment. We gather1199 !! the 4+kextj northern lines of the global domain on 11200 !! processor and apply lbc north-fold on this sub array.1201 !! Then we scatter the north fold array back to the processors.1202 !! This routine accounts for an extra halo with icebergs1203 !! and assumes ghost rows and columns have been suppressed.1204 !!1205 !!----------------------------------------------------------------------1206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1208 ! ! = T , U , V , F or W -points1209 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1210 !! ! north fold, = 1. otherwise1211 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1212 !1213 INTEGER :: ji, jj, jr1214 INTEGER :: ierr, itaille, ildi, ilei, iilb1215 INTEGER :: ipj, ij, iproc1216 !1217 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1218 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1219 !!----------------------------------------------------------------------1220 !1221 ipj=41222 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1223 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1224 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1225 !1226 ztab_e(:,:) = 0._wp1227 znorthloc_e(:,:) = 0._wp1228 !1229 ij = 1 - kextj1230 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1231 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1232 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1233 ij = ij + 11234 END DO1235 !1236 itaille = jpimax * ( ipj + 2*kextj )1237 !1238 IF( ln_timing ) CALL tic_tac(.TRUE.)1239 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1240 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1241 & ncomm_north, ierr )1242 !1243 IF( ln_timing ) CALL tic_tac(.FALSE.)1244 !1245 DO jr = 1, ndim_rank_north ! recover the global north array1246 iproc = nrank_north(jr) + 11247 ildi = nldit (iproc)1248 ilei = nleit (iproc)1249 iilb = nimppt(iproc)1250 DO jj = 1-kextj, ipj+kextj1251 DO ji = ildi, ilei1252 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1253 END DO1254 END DO1255 END DO1256 1257 ! 2. North-Fold boundary conditions1258 ! ----------------------------------1259 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1260 1261 ij = 1 - kextj1262 !! Scatter back to pt2d1263 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1264 DO ji= 1, jpi1265 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1266 END DO1267 ij = ij +11268 END DO1269 !1270 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1271 !1272 END SUBROUTINE mpp_lbc_north_icb1273 1274 1275 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1276 !!----------------------------------------------------------------------1277 !! *** routine mpp_lnk_2d_icb ***1278 !!1279 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1280 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1281 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1282 !!1283 !! ** Method : Use mppsend and mpprecv function for passing mask1284 !! between processors following neighboring subdomains.1285 !! domain parameters1286 !! jpi : first dimension of the local subdomain1287 !! jpj : second dimension of the local subdomain1288 !! kexti : number of columns for extra outer halo1289 !! kextj : number of rows for extra outer halo1290 !! nbondi : mark for "east-west local boundary"1291 !! nbondj : mark for "north-south local boundary"1292 !! noea : number for local neighboring processors1293 !! nowe : number for local neighboring processors1294 !! noso : number for local neighboring processors1295 !! nono : number for local neighboring processors1296 !!----------------------------------------------------------------------1297 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1298 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1299 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1300 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1301 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1302 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1303 !1304 INTEGER :: jl ! dummy loop indices1305 INTEGER :: imigr, iihom, ijhom ! local integers1306 INTEGER :: ipreci, iprecj ! - -1307 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1308 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1309 !!1310 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1311 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1312 !!----------------------------------------------------------------------1313 1314 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1315 iprecj = nn_hls + kextj1316 1317 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1318 1319 ! 1. standard boundary treatment1320 ! ------------------------------1321 ! Order matters Here !!!!1322 !1323 ! ! East-West boundaries1324 ! !* Cyclic east-west1325 IF( l_Iperio ) THEN1326 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1327 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1328 !1329 ELSE !* closed1330 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1331 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1332 ENDIF1333 ! ! North-South boundaries1334 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1335 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1336 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1337 ELSE !* closed1338 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1339 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1340 ENDIF1341 !1342 1343 ! north fold treatment1344 ! -----------------------1345 IF( npolj /= 0 ) THEN1346 !1347 SELECT CASE ( jpni )1348 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1349 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1350 END SELECT1351 !1352 ENDIF1353 1354 ! 2. East and west directions exchange1355 ! ------------------------------------1356 ! we play with the neigbours AND the row number because of the periodicity1357 !1358 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1359 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1360 iihom = jpi-nreci-kexti1361 DO jl = 1, ipreci1362 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1363 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1364 END DO1365 END SELECT1366 !1367 ! ! Migrations1368 imigr = ipreci * ( jpj + 2*kextj )1369 !1370 IF( ln_timing ) CALL tic_tac(.TRUE.)1371 !1372 SELECT CASE ( nbondi )1373 CASE ( -1 )1374 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1375 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1376 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1377 CASE ( 0 )1378 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1379 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1380 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1381 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1382 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1383 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1384 CASE ( 1 )1385 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1386 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1387 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1388 END SELECT1389 !1390 IF( ln_timing ) CALL tic_tac(.FALSE.)1391 !1392 ! ! Write Dirichlet lateral conditions1393 iihom = jpi - nn_hls1394 !1395 SELECT CASE ( nbondi )1396 CASE ( -1 )1397 DO jl = 1, ipreci1398 pt2d(iihom+jl,:) = r2dew(:,jl,2)1399 END DO1400 CASE ( 0 )1401 DO jl = 1, ipreci1402 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1403 pt2d(iihom+jl,:) = r2dew(:,jl,2)1404 END DO1405 CASE ( 1 )1406 DO jl = 1, ipreci1407 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1408 END DO1409 END SELECT1410 1411 1412 ! 3. North and south directions1413 ! -----------------------------1414 ! always closed : we play only with the neigbours1415 !1416 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1417 ijhom = jpj-nrecj-kextj1418 DO jl = 1, iprecj1419 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1420 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1421 END DO1422 ENDIF1423 !1424 ! ! Migrations1425 imigr = iprecj * ( jpi + 2*kexti )1426 !1427 IF( ln_timing ) CALL tic_tac(.TRUE.)1428 !1429 SELECT CASE ( nbondj )1430 CASE ( -1 )1431 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1432 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1433 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1434 CASE ( 0 )1435 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1436 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1437 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1438 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1439 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1440 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1441 CASE ( 1 )1442 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1443 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1444 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1445 END SELECT1446 !1447 IF( ln_timing ) CALL tic_tac(.FALSE.)1448 !1449 ! ! Write Dirichlet lateral conditions1450 ijhom = jpj - nn_hls1451 !1452 SELECT CASE ( nbondj )1453 CASE ( -1 )1454 DO jl = 1, iprecj1455 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1456 END DO1457 CASE ( 0 )1458 DO jl = 1, iprecj1459 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1460 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1461 END DO1462 CASE ( 1 )1463 DO jl = 1, iprecj1464 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1465 END DO1466 END SELECT1467 !1468 END SUBROUTINE mpp_lnk_2d_icb1469 1470 1183 1471 1184 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg )
Note: See TracChangeset
for help on using the changeset viewer.
