- Timestamp:
- 2017-12-13T14:57:33+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8882 r9012 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_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)44 43 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 45 44 !! mpprecv : … … 55 54 !! mppstop : 56 55 !! mpp_ini_north : initialisation of north fold 57 !!gm !! mpp_lbc_north : north fold processors gathering 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 56 !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs 60 57 !!---------------------------------------------------------------------- 61 58 USE dom_oce ! ocean space and time domain … … 75 72 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 76 73 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 77 PUBLIC mpp_lnk_2d_e78 74 ! 79 75 !!gm this should be useless … … 84 80 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 85 81 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 86 PUBLIC mpp_ini_north , mpp_lbc_north_e87 !!gm PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 88 PUBLIC mpp_lbc_north_icb , mpp_lnk_2d_icb82 PUBLIC mpp_ini_north 83 PUBLIC mpp_lnk_2d_icb 84 PUBLIC mpp_lbc_north_icb 89 85 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 90 86 PUBLIC mpp_max_multiple 91 !!gm PUBLIC mpp_lnk_2d_992 !!gm PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d93 87 PUBLIC mppscatter, mppgather 94 88 PUBLIC mpp_ini_ice, mpp_ini_znl … … 112 106 & mppsum_realdd, mppsum_a_realdd 113 107 END INTERFACE 114 !!gm INTERFACE mpp_lbc_north115 !!gm MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d116 !!gm END INTERFACE117 108 INTERFACE mpp_minloc 118 109 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 145 136 146 137 ! variables used in case of sea-ice 147 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in icethd)138 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 148 139 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology) 149 140 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology) … … 454 445 # include "mpp_bdy_generic.h90" 455 446 # undef ROUTINE_BDY 456 # define MULTI457 # define ROUTINE_BDY mpp_lnk_bdy_2d_ptr458 # include "mpp_bdy_generic.h90"459 # undef ROUTINE_BDY460 # undef MULTI461 447 # undef DIM_2d 462 448 ! … … 467 453 # include "mpp_bdy_generic.h90" 468 454 # undef ROUTINE_BDY 469 # define MULTI470 # define ROUTINE_BDY mpp_lnk_bdy_3d_ptr471 # include "mpp_bdy_generic.h90"472 # undef ROUTINE_BDY473 # undef MULTI474 455 # undef DIM_3d 475 456 ! … … 480 461 !!# include "mpp_bdy_generic.h90" 481 462 !!# undef ROUTINE_BDY 482 !!# define MULTI483 !!# define ROUTINE_BDY mpp_lnk_bdy_4d_ptr484 !!# include "mpp_bdy_generic.h90"485 !!# undef ROUTINE_BDY486 !!# undef MULTI487 463 !!# undef DIM_4d 488 464 … … 492 468 493 469 494 !! mpp_lnk_2d_e utilisé dans ICB495 496 497 470 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 498 471 … … 500 473 !!---------------------------------------------------------------------- 501 474 502 503 SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )504 !!----------------------------------------------------------------------505 !! *** routine mpp_lnk_2d_e ***506 !!507 !! ** Purpose : Message passing manadgement for 2d array (with halo)508 !!509 !! ** Method : Use mppsend and mpprecv function for passing mask510 !! between processors following neighboring subdomains.511 !! domain parameters512 !! nlci : first dimension of the local subdomain513 !! nlcj : second dimension of the local subdomain514 !! jpri : number of rows for extra outer halo515 !! jprj : number of columns for extra outer halo516 !! nbondi : mark for "east-west local boundary"517 !! nbondj : mark for "north-south local boundary"518 !! noea : number for local neighboring processors519 !! nowe : number for local neighboring processors520 !! noso : number for local neighboring processors521 !! nono : number for local neighboring processors522 !!523 !!----------------------------------------------------------------------524 INTEGER , INTENT(in ) :: jpri525 INTEGER , INTENT(in ) :: jprj526 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo527 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points528 ! ! = T , U , V , F , W and I points529 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the530 !! ! north boundary, = 1. otherwise531 INTEGER :: jl ! dummy loop indices532 INTEGER :: imigr, iihom, ijhom ! temporary integers533 INTEGER :: ipreci, iprecj ! temporary integers534 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend535 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend536 !!537 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns538 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn539 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe540 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew541 !!----------------------------------------------------------------------542 543 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area544 iprecj = jprecj + jprj545 546 547 ! 1. standard boundary treatment (CAUTION: the order matters Here !!!! )548 ! ------------------------------549 ! !== North-South boundaries550 ! !* cyclic551 IF( nbondj == 2 .AND. jperio == 7 ) THEN552 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1 )553 pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj)554 ELSE !* closed555 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0._wp ! south except at F-point556 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp ! north557 ENDIF558 ! !== East-West boundaries559 ! !* Cyclic east-west560 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN561 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east562 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west563 ELSE !* closed564 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point565 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north566 ENDIF567 !568 ! north fold treatment569 ! --------------------570 IF( npolj /= 0 ) THEN571 !572 SELECT CASE ( jpni )573 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )574 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )575 END SELECT576 !577 ENDIF578 579 ! 2. East and west directions exchange580 ! ------------------------------------581 ! we play with the neigbours AND the row number because of the periodicity582 !583 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions584 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)585 iihom = nlci-nreci-jpri586 DO jl = 1, ipreci587 r2dew(:,jl,1) = pt2d(jpreci+jl,:)588 r2dwe(:,jl,1) = pt2d(iihom +jl,:)589 END DO590 END SELECT591 !592 ! ! Migrations593 imigr = ipreci * ( jpj + 2*jprj)594 !595 SELECT CASE ( nbondi )596 CASE ( -1 )597 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )598 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )599 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)600 CASE ( 0 )601 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )602 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )603 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )604 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )605 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)606 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)607 CASE ( 1 )608 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )609 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )610 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)611 END SELECT612 !613 ! ! Write Dirichlet lateral conditions614 iihom = nlci - jpreci615 !616 SELECT CASE ( nbondi )617 CASE ( -1 )618 DO jl = 1, ipreci619 pt2d(iihom+jl,:) = r2dew(:,jl,2)620 END DO621 CASE ( 0 )622 DO jl = 1, ipreci623 pt2d(jl-jpri,:) = r2dwe(:,jl,2)624 pt2d( iihom+jl,:) = r2dew(:,jl,2)625 END DO626 CASE ( 1 )627 DO jl = 1, ipreci628 pt2d(jl-jpri,:) = r2dwe(:,jl,2)629 END DO630 END SELECT631 632 ! 3. North and south directions633 ! -----------------------------634 ! always closed : we play only with the neigbours635 !636 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions637 ijhom = nlcj-nrecj-jprj638 DO jl = 1, iprecj639 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)640 r2dns(:,jl,1) = pt2d(:,jprecj+jl)641 END DO642 ENDIF643 !644 ! ! Migrations645 imigr = iprecj * ( jpi + 2*jpri )646 !647 SELECT CASE ( nbondj )648 CASE ( -1 )649 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )650 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )651 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)652 CASE ( 0 )653 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )654 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )655 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )656 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )657 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)658 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)659 CASE ( 1 )660 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )661 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )662 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)663 END SELECT664 !665 ! ! Write Dirichlet lateral conditions666 ijhom = nlcj - jprecj667 !668 SELECT CASE ( nbondj )669 CASE ( -1 )670 DO jl = 1, iprecj671 pt2d(:,ijhom+jl) = r2dns(:,jl,2)672 END DO673 CASE ( 0 )674 DO jl = 1, iprecj675 pt2d(:,jl-jprj) = r2dsn(:,jl,2)676 pt2d(:,ijhom+jl ) = r2dns(:,jl,2)677 END DO678 CASE ( 1 )679 DO jl = 1, iprecj680 pt2d(:,jl-jprj) = r2dsn(:,jl,2)681 END DO682 END SELECT683 !684 END SUBROUTINE mpp_lnk_2d_e685 475 686 476 … … 1458 1248 1459 1249 1460 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)1461 !!---------------------------------------------------------------------1462 !! *** routine mpp_lbc_north_2d ***1463 !!1464 !! ** Purpose : Ensure proper north fold horizontal bondary condition1465 !! in mpp configuration in case of jpn1 > 1 and for 2d1466 !! array with outer extra halo1467 !!1468 !! ** Method : North fold condition and mpp with more than one proc1469 !! in i-direction require a specific treatment. We gather1470 !! the 4+2*jpr2dj northern lines of the global domain on 11471 !! processor and apply lbc north-fold on this sub array.1472 !! Then we scatter the north fold array back to the processors.1473 !!1474 !!----------------------------------------------------------------------1475 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo1476 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1477 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1478 !1479 INTEGER :: ji, jj, jr1480 INTEGER :: ierr, itaille, ildi, ilei, iilb1481 INTEGER :: ijpj, ij, iproc1482 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1483 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1484 !!----------------------------------------------------------------------1485 !1486 ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )1487 !1488 ijpj=41489 ztab_e(:,:) = 0._wp1490 1491 ij = 01492 ! put in znorthloc_e the last 4 jlines of pt2d1493 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj1494 ij = ij + 11495 DO ji = 1, jpi1496 znorthloc_e(ji,ij) = pt2d(ji,jj)1497 END DO1498 END DO1499 !1500 itaille = jpi * ( ijpj + 2 * jpr2dj )1501 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &1502 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )1503 !1504 DO jr = 1, ndim_rank_north ! recover the global north array1505 iproc = nrank_north(jr) + 11506 ildi = nldit (iproc)1507 ilei = nleit (iproc)1508 iilb = nimppt(iproc)1509 DO jj = 1, ijpj+2*jpr2dj1510 DO ji = ildi, ilei1511 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1512 END DO1513 END DO1514 END DO1515 1516 ! 2. North-Fold boundary conditions1517 ! ----------------------------------1518 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )1519 1520 ij = jpr2dj1521 !! Scatter back to pt2d1522 DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj1523 ij = ij +11524 DO ji= 1, nlci1525 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1526 END DO1527 END DO1528 !1529 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1530 !1531 END SUBROUTINE mpp_lbc_north_e1532 1533 1534 1250 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 1535 1251 !!--------------------------------------------------------------------- … … 1623 1339 1624 1340 1625 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)1341 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 1626 1342 !!--------------------------------------------------------------------- 1627 1343 !! *** routine mpp_lbc_north_icb *** … … 1633 1349 !! ** Method : North fold condition and mpp with more than one proc 1634 1350 !! in i-direction require a specific treatment. We gather 1635 !! the 4+ 2*jpr2dj northern lines of the global domain on 11351 !! the 4+kextj northern lines of the global domain on 1 1636 1352 !! processor and apply lbc north-fold on this sub array. 1637 1353 !! Then we scatter the north fold array back to the processors. 1638 !! This version accounts for an extra halo with icebergs. 1354 !! This routine accounts for an extra halo with icebergs 1355 !! and assumes ghost rows and columns have been suppressed. 1639 1356 !! 1640 1357 !!---------------------------------------------------------------------- … … 1644 1361 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 1645 1362 !! ! north fold, = 1. otherwise 1646 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj1363 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 1647 1364 ! 1648 1365 INTEGER :: ji, jj, jr 1649 1366 INTEGER :: ierr, itaille, ildi, ilei, iilb 1650 INTEGER :: i jpj, ij, iproc, ipr2dj1367 INTEGER :: ipj, ij, iproc 1651 1368 ! 1652 1369 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e … … 1654 1371 !!---------------------------------------------------------------------- 1655 1372 ! 1656 ijpj=4 1657 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 1658 ipr2dj = pr2dj 1659 ELSE 1660 ipr2dj = 0 1661 ENDIF 1662 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 1663 ! 1664 ztab_e(:,:) = 0._wp 1373 ipj=4 1374 ALLOCATE( ztab_e(jpiglo,ipj+kextj), znorthloc_e( jpimax,ipj+kextj), & 1375 & znorthgloio_e(jpimax,ipj+kextj,jpni) ) 1376 ! 1377 ztab_e(:,:) = 0._wp 1378 znorthloc_e(:,:) = 0._wp 1665 1379 ! 1666 1380 ij = 0 1667 ! put in znorthloc_e the last 4 jlines of pt2d1668 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj1381 ! put the last ipj+kextj lines of pt2d into znorthloc_e 1382 DO jj = jpj - ipj + 1, jpj + kextj 1669 1383 ij = ij + 1 1670 DO ji = 1, jpi 1671 znorthloc_e(ji,ij)=pt2d(ji,jj) 1672 END DO 1384 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 1673 1385 END DO 1674 1386 ! 1675 itaille = jpi * ( ijpj + 2 * ipr2dj )1387 itaille = jpimax * ( ipj + kextj ) 1676 1388 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 1677 1389 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) … … 1682 1394 ilei = nleit (iproc) 1683 1395 iilb = nimppt(iproc) 1684 DO jj = 1, i jpj+2*ipr2dj1396 DO jj = 1, ipj+kextj 1685 1397 DO ji = ildi, ilei 1686 1398 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) … … 1691 1403 ! 2. North-Fold boundary conditions 1692 1404 ! ---------------------------------- 1693 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )1694 1695 ij = ipr2dj1405 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, kextj ) 1406 1407 ij = 0 1696 1408 !! Scatter back to pt2d 1697 DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj1409 DO jj = jpj - ipj + 1 , jpj + kextj 1698 1410 ij = ij +1 1699 DO ji= 1, nlci1411 DO ji= 1, jpi 1700 1412 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 1701 1413 END DO … … 1707 1419 1708 1420 1709 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )1421 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj ) 1710 1422 !!---------------------------------------------------------------------- 1711 1423 !! *** routine mpp_lnk_2d_icb *** 1712 1424 !! 1713 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 1425 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 1426 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 1427 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 1714 1428 !! 1715 1429 !! ** Method : Use mppsend and mpprecv function for passing mask 1716 1430 !! between processors following neighboring subdomains. 1717 1431 !! domain parameters 1718 !! nlci: first dimension of the local subdomain1719 !! nlcj: second dimension of the local subdomain1720 !! jpri : number of rows for extra outer halo1721 !! jprj : number of columns for extra outer halo1432 !! jpi : first dimension of the local subdomain 1433 !! jpj : second dimension of the local subdomain 1434 !! kexti : number of columns for extra outer halo 1435 !! kextj : number of rows for extra outer halo 1722 1436 !! nbondi : mark for "east-west local boundary" 1723 1437 !! nbondj : mark for "north-south local boundary" … … 1727 1441 !! nono : number for local neighboring processors 1728 1442 !!---------------------------------------------------------------------- 1729 REAL(wp), DIMENSION(1- jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo1730 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1731 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1732 INTEGER , INTENT(in ) :: jpri1733 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 1734 1448 ! 1735 1449 INTEGER :: jl ! dummy loop indices … … 1739 1453 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1740 1454 !! 1741 REAL(wp), DIMENSION(1- jpri:jpi+jpri,jprecj+jprj,2) :: r2dns, r2dsn1742 REAL(wp), DIMENSION(1- jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe, r2dew1743 !!---------------------------------------------------------------------- 1744 1745 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area1746 iprecj = jprecj + 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 1747 1461 1748 1462 … … 1754 1468 ! !* Cyclic east-west 1755 1469 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1756 pt2d(1- jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east1757 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 1758 1472 ! 1759 1473 ELSE !* closed 1760 IF( .NOT. cd_type == 'F' ) pt2d( 1- jpri :jpreci,:) = 0._wp ! south except at F-point1761 pt2d( nlci-jpreci+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 1762 1476 ENDIF 1763 1477 ! … … 1768 1482 ! 1769 1483 SELECT CASE ( jpni ) 1770 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )1771 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=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 ) 1772 1486 END SELECT 1773 1487 ! … … 1780 1494 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1781 1495 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1782 iihom = nlci-nreci-jpri1496 iihom = jpi-nreci-kexti 1783 1497 DO jl = 1, ipreci 1784 r2dew(:,jl,1) = pt2d( jpreci+jl,:)1498 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 1785 1499 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 1786 1500 END DO … … 1788 1502 ! 1789 1503 ! ! Migrations 1790 imigr = ipreci * ( jpj + 2* jprj)1504 imigr = ipreci * ( jpj + 2*kextj ) 1791 1505 ! 1792 1506 SELECT CASE ( nbondi ) 1793 1507 CASE ( -1 ) 1794 CALL mppsend( 2, r2dwe(1- jprj,1,1), imigr, noea, ml_req1 )1795 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 ) 1796 1510 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1797 1511 CASE ( 0 ) 1798 CALL mppsend( 1, r2dew(1- jprj,1,1), imigr, nowe, ml_req1 )1799 CALL mppsend( 2, r2dwe(1- jprj,1,1), imigr, noea, ml_req2 )1800 CALL mpprecv( 1, r2dew(1- jprj,1,2), imigr, noea )1801 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 ) 1802 1516 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1803 1517 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1804 1518 CASE ( 1 ) 1805 CALL mppsend( 1, r2dew(1- jprj,1,1), imigr, nowe, ml_req1 )1806 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 ) 1807 1521 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1808 1522 END SELECT 1809 1523 ! 1810 1524 ! ! Write Dirichlet lateral conditions 1811 iihom = nlci - jpreci1525 iihom = jpi - nn_hls 1812 1526 ! 1813 1527 SELECT CASE ( nbondi ) … … 1818 1532 CASE ( 0 ) 1819 1533 DO jl = 1, ipreci 1820 pt2d(jl- jpri,:) = r2dwe(:,jl,2)1821 pt2d( 1534 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 1535 pt2d(iihom+jl,:) = r2dew(:,jl,2) 1822 1536 END DO 1823 1537 CASE ( 1 ) 1824 1538 DO jl = 1, ipreci 1825 pt2d(jl- jpri,:) = r2dwe(:,jl,2)1539 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 1826 1540 END DO 1827 1541 END SELECT … … 1833 1547 ! 1834 1548 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1835 ijhom = nlcj-nrecj-jprj1549 ijhom = jpj-nrecj-kextj 1836 1550 DO jl = 1, iprecj 1837 1551 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 1838 r2dns(:,jl,1) = pt2d(:, jprecj+jl)1552 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 1839 1553 END DO 1840 1554 ENDIF 1841 1555 ! 1842 1556 ! ! Migrations 1843 imigr = iprecj * ( jpi + 2* jpri )1557 imigr = iprecj * ( jpi + 2*kexti ) 1844 1558 ! 1845 1559 SELECT CASE ( nbondj ) 1846 1560 CASE ( -1 ) 1847 CALL mppsend( 4, r2dsn(1- jpri,1,1), imigr, nono, ml_req1 )1848 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 ) 1849 1563 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1850 1564 CASE ( 0 ) 1851 CALL mppsend( 3, r2dns(1- jpri,1,1), imigr, noso, ml_req1 )1852 CALL mppsend( 4, r2dsn(1- jpri,1,1), imigr, nono, ml_req2 )1853 CALL mpprecv( 3, r2dns(1- jpri,1,2), imigr, nono )1854 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 ) 1855 1569 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1856 1570 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1857 1571 CASE ( 1 ) 1858 CALL mppsend( 3, r2dns(1- jpri,1,1), imigr, noso, ml_req1 )1859 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 ) 1860 1574 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1861 1575 END SELECT 1862 1576 ! 1863 1577 ! ! Write Dirichlet lateral conditions 1864 ijhom = nlcj - jprecj1578 ijhom = jpj - nn_hls 1865 1579 ! 1866 1580 SELECT CASE ( nbondj ) … … 1871 1585 CASE ( 0 ) 1872 1586 DO jl = 1, iprecj 1873 pt2d(:,jl- jprj) = r2dsn(:,jl,2)1874 pt2d(:,ijhom+jl 1587 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 1588 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 1875 1589 END DO 1876 1590 CASE ( 1 ) 1877 1591 DO jl = 1, iprecj 1878 pt2d(:,jl- jprj) = r2dsn(:,jl,2)1592 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 1879 1593 END DO 1880 1594 END SELECT
Note: See TracChangeset
for help on using the changeset viewer.
