- Timestamp:
- 2017-11-30T16:11:05+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8811 r8860 1339 1339 1340 1340 1341 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, ipr2dj)1341 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 1342 1342 !!--------------------------------------------------------------------- 1343 1343 !! *** routine mpp_lbc_north_icb *** … … 1349 1349 !! ** Method : North fold condition and mpp with more than one proc 1350 1350 !! in i-direction require a specific treatment. We gather 1351 !! the 4+ 2*jpr2dj northern lines of the global domain on 11351 !! the 4+kextj northern lines of the global domain on 1 1352 1352 !! processor and apply lbc north-fold on this sub array. 1353 1353 !! Then we scatter the north fold array back to the processors. … … 1361 1361 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 1362 1362 !! ! north fold, = 1. otherwise 1363 INTEGER , INTENT(in ) :: ipr2dj1363 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 1364 1364 ! 1365 1365 INTEGER :: ji, jj, jr … … 1372 1372 ! 1373 1373 ipj=4 1374 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpimax,4+2*ipr2dj), znorthgloio_e(jpimax,4+2*ipr2dj,jpni) ) 1374 ALLOCATE( ztab_e(jpiglo,ipj+kextj), znorthloc_e( jpimax,ipj+kextj), & 1375 & znorthgloio_e(jpimax,ipj+kextj,jpni) ) 1375 1376 ! 1376 1377 ztab_e(:,:) = 0._wp … … 1378 1379 ! 1379 1380 ij = 0 1380 ! put the last 4+2*ipr2dj lines of pt2d into znorthloc_e1381 DO jj = jpj - ipj + 1 - ipr2dj, jpj +ipr2dj1381 ! put the last ipj+kextj lines of pt2d into znorthloc_e 1382 DO jj = jpj - ipj + 1, jpj + kextj 1382 1383 ij = ij + 1 1383 1384 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 1384 1385 END DO 1385 1386 ! 1386 itaille = jpimax * ( ipj + 2 * ipr2dj )1387 itaille = jpimax * ( ipj + kextj ) 1387 1388 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 1388 1389 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) … … 1393 1394 ilei = nleit (iproc) 1394 1395 iilb = nimppt(iproc) 1395 DO jj = 1, ipj+ 2*ipr2dj1396 DO jj = 1, ipj+kextj 1396 1397 DO ji = ildi, ilei 1397 1398 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) … … 1402 1403 ! 2. North-Fold boundary conditions 1403 1404 ! ---------------------------------- 1404 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, ipr2dj )1405 1406 ij = ipr2dj1405 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, kextj ) 1406 1407 ij = 0 1407 1408 !! Scatter back to pt2d 1408 DO jj = jpj - ipj + 1 , jpj + ipr2dj1409 DO jj = jpj - ipj + 1 , jpj + kextj 1409 1410 ij = ij +1 1410 1411 DO ji= 1, jpi … … 1418 1419 1419 1420 1420 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )1421 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj ) 1421 1422 !!---------------------------------------------------------------------- 1422 1423 !! *** routine mpp_lnk_2d_icb *** 1423 1424 !! 1424 1425 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 1425 !! This routine receives a (1- jpri:jpi+jpri,1-jpri:jpj+jprj)1426 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 1426 1427 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 1427 1428 !! … … 1431 1432 !! jpi : first dimension of the local subdomain 1432 1433 !! jpj : second dimension of the local subdomain 1433 !! jpri : number of rows for extra outer halo1434 !! jprj : number of columns for extra outer halo1434 !! kexti : number of columns for extra outer halo 1435 !! kextj : number of rows for extra outer halo 1435 1436 !! nbondi : mark for "east-west local boundary" 1436 1437 !! nbondj : mark for "north-south local boundary" … … 1440 1441 !! nono : number for local neighboring processors 1441 1442 !!---------------------------------------------------------------------- 1442 REAL(wp), DIMENSION(1- jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo1443 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1444 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1445 INTEGER , INTENT(in ) :: jpri1446 INTEGER , INTENT(in ) :: jprj1443 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 1444 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 1445 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 1446 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 1447 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 1447 1448 ! 1448 1449 INTEGER :: jl ! dummy loop indices … … 1452 1453 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1453 1454 !! 1454 REAL(wp), DIMENSION(1- jpri:jpi+jpri,nn_hls+jprj,2) :: r2dns, r2dsn1455 REAL(wp), DIMENSION(1- jprj:jpj+jprj,nn_hls+jpri,2) :: r2dwe, r2dew1456 !!---------------------------------------------------------------------- 1457 1458 ipreci = nn_hls + jpri ! take into account outer extra 2D overlap area1459 iprecj = nn_hls + jprj1455 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 1456 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 1457 !!---------------------------------------------------------------------- 1458 1459 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 1460 iprecj = nn_hls + kextj 1460 1461 1461 1462 … … 1467 1468 ! !* Cyclic east-west 1468 1469 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1469 pt2d(1- jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east1470 pt2d( jpi :jpi+ jpri,:) = pt2d( 2 :2+jpri,:) ! west1470 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 1471 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 1471 1472 ! 1472 1473 ELSE !* closed 1473 IF( .NOT. cd_type == 'F' ) pt2d( 1- jpri :nn_hls ,:) = 0._wp ! south except at F-point1474 pt2d(jpi-nn_hls+1:jpi+ jpri,:) = 0._wp ! north1474 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! south except at F-point 1475 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! north 1475 1476 ENDIF 1476 1477 ! … … 1481 1482 ! 1482 1483 SELECT CASE ( jpni ) 1483 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, jprj )1484 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+ jprj) , cd_type, psgn , jprj)1484 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 1485 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 1485 1486 END SELECT 1486 1487 ! … … 1493 1494 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1494 1495 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1495 iihom = jpi-nreci- jpri1496 iihom = jpi-nreci-kexti 1496 1497 DO jl = 1, ipreci 1497 1498 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) … … 1501 1502 ! 1502 1503 ! ! Migrations 1503 imigr = ipreci * ( jpj + 2* jprj)1504 imigr = ipreci * ( jpj + 2*kextj ) 1504 1505 ! 1505 1506 SELECT CASE ( nbondi ) 1506 1507 CASE ( -1 ) 1507 CALL mppsend( 2, r2dwe(1- jprj,1,1), imigr, noea, ml_req1 )1508 CALL mpprecv( 1, r2dew(1- jprj,1,2), imigr, noea )1508 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 1509 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 1509 1510 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1510 1511 CASE ( 0 ) 1511 CALL mppsend( 1, r2dew(1- jprj,1,1), imigr, nowe, ml_req1 )1512 CALL mppsend( 2, r2dwe(1- jprj,1,1), imigr, noea, ml_req2 )1513 CALL mpprecv( 1, r2dew(1- jprj,1,2), imigr, noea )1514 CALL mpprecv( 2, r2dwe(1- jprj,1,2), imigr, nowe )1512 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 1513 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 1514 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 1515 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 1515 1516 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1516 1517 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1517 1518 CASE ( 1 ) 1518 CALL mppsend( 1, r2dew(1- jprj,1,1), imigr, nowe, ml_req1 )1519 CALL mpprecv( 2, r2dwe(1- jprj,1,2), imigr, nowe )1519 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 1520 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 1520 1521 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1521 1522 END SELECT … … 1531 1532 CASE ( 0 ) 1532 1533 DO jl = 1, ipreci 1533 pt2d(jl- jpri,:) = r2dwe(:,jl,2)1534 pt2d( 1534 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 1535 pt2d(iihom+jl,:) = r2dew(:,jl,2) 1535 1536 END DO 1536 1537 CASE ( 1 ) 1537 1538 DO jl = 1, ipreci 1538 pt2d(jl- jpri,:) = r2dwe(:,jl,2)1539 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 1539 1540 END DO 1540 1541 END SELECT … … 1546 1547 ! 1547 1548 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1548 ijhom = jpj-nrecj- jprj1549 ijhom = jpj-nrecj-kextj 1549 1550 DO jl = 1, iprecj 1550 1551 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) … … 1554 1555 ! 1555 1556 ! ! Migrations 1556 imigr = iprecj * ( jpi + 2* jpri )1557 imigr = iprecj * ( jpi + 2*kexti ) 1557 1558 ! 1558 1559 SELECT CASE ( nbondj ) 1559 1560 CASE ( -1 ) 1560 CALL mppsend( 4, r2dsn(1- jpri,1,1), imigr, nono, ml_req1 )1561 CALL mpprecv( 3, r2dns(1- jpri,1,2), imigr, nono )1561 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 1562 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 1562 1563 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1563 1564 CASE ( 0 ) 1564 CALL mppsend( 3, r2dns(1- jpri,1,1), imigr, noso, ml_req1 )1565 CALL mppsend( 4, r2dsn(1- jpri,1,1), imigr, nono, ml_req2 )1566 CALL mpprecv( 3, r2dns(1- jpri,1,2), imigr, nono )1567 CALL mpprecv( 4, r2dsn(1- jpri,1,2), imigr, noso )1565 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 1566 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 1567 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 1568 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 1568 1569 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1569 1570 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1570 1571 CASE ( 1 ) 1571 CALL mppsend( 3, r2dns(1- jpri,1,1), imigr, noso, ml_req1 )1572 CALL mpprecv( 4, r2dsn(1- jpri,1,2), imigr, noso )1572 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 1573 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 1573 1574 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1574 1575 END SELECT … … 1584 1585 CASE ( 0 ) 1585 1586 DO jl = 1, iprecj 1586 pt2d(:,jl- jprj) = r2dsn(:,jl,2)1587 pt2d(:,ijhom+jl 1587 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 1588 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 1588 1589 END DO 1589 1590 CASE ( 1 ) 1590 1591 DO jl = 1, iprecj 1591 pt2d(:,jl- jprj) = r2dsn(:,jl,2)1592 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 1592 1593 END DO 1593 1594 END SELECT
Note: See TracChangeset
for help on using the changeset viewer.
