Changeset 311
- Timestamp:
- 2005-09-30T12:18:52+02:00 (19 years ago)
- Location:
- trunk/NEMO/OPA_SRC
- Files:
-
- 5 edited
-
lbclnk.F90 (modified) (3 diffs)
-
lib_mpp.F90 (modified) (5 diffs)
-
par_oce.F90 (modified) (1 diff)
-
restart.F90 (modified) (4 diffs)
-
restart_dimg.h90 (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OPA_SRC/lbclnk.F90
r288 r311 12 12 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d 13 13 !! routines defined in lib_mpp 14 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e 15 !! routinee defined in lib_mpp 14 16 !!---------------------------------------------------------------------- 15 17 !! * Modules used … … 20 22 END INTERFACE 21 23 24 INTERFACE lbc_lnk_e 25 MODULE PROCEDURE mpp_lnk_2d_e 26 END INTERFACE 27 22 28 PUBLIC lbc_lnk ! ocean lateral boundary conditions 29 PUBLIC lbc_lnk_e 23 30 !!---------------------------------------------------------------------- 24 31 … … 45 52 END INTERFACE 46 53 54 INTERFACE lbc_lnk_e 55 MODULE PROCEDURE lbc_lnk_2d 56 END INTERFACE 57 47 58 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 59 PUBLIC lbc_lnk_e 48 60 !!---------------------------------------------------------------------- 49 61 -
trunk/NEMO/OPA_SRC/lib_mpp.F90
r300 r311 14 14 !! mpp_lnk : generic interface (defined in lbclnk) for : 15 15 !! mpp_lnk_2d, mpp_lnk_3d 16 !! mpp_lnk_e : interface defined in lbclnk 16 17 !! mpplnks 17 18 !! mpprecv … … 32 33 !! mpp_ini_north 33 34 !! mpp_lbc_north 35 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo (nsolv=4) 34 36 !!---------------------------------------------------------------------- 35 37 !! History : … … 244 246 REAL(wp), DIMENSION(jpi,jprecj,2) :: & 245 247 t2p1, t2p2 ! 2d message passing arrays north fold 248 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) :: & 249 tr2ns, tr2sn ! 2d message passing arrays north-south & south-north including extra outer halo 250 REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) :: & 251 tr2ew, tr2we ! 2d message passing arrays east-west & west-east including extra outer halo 246 252 !!---------------------------------------------------------------------- 247 253 !! OPA 9.0 , LOCEAN-IPSL (2005) … … 1376 1382 1377 1383 1384 SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn ) 1385 !!---------------------------------------------------------------------- 1386 !! *** routine mpp_lnk_2d_e *** 1387 !! 1388 !! ** Purpose : Message passing manadgement for 2d array (with halo) 1389 !! 1390 !! ** Method : Use mppsend and mpprecv function for passing mask 1391 !! between processors following neighboring subdomains. 1392 !! domain parameters 1393 !! nlci : first dimension of the local subdomain 1394 !! nlcj : second dimension of the local subdomain 1395 !! jpr2di : number of rows for extra outer halo 1396 !! jpr2dj : number of columns for extra outer halo 1397 !! nbondi : mark for "east-west local boundary" 1398 !! nbondj : mark for "north-south local boundary" 1399 !! noea : number for local neighboring processors 1400 !! nowe : number for local neighboring processors 1401 !! noso : number for local neighboring processors 1402 !! nono : number for local neighboring processors 1403 !! 1404 !! History : 1405 !! 1406 !! 9.0 ! 05-09 (R. Benshila, G. Madec) original code 1407 !! 1408 !!---------------------------------------------------------------------- 1409 !! * Arguments 1410 CHARACTER(len=1) , INTENT( in ) :: & 1411 cd_type ! define the nature of pt2d array grid-points 1412 ! ! = T , U , V , F , W 1413 ! ! = S : T-point, north fold treatment 1414 ! ! = G : F-point, north fold treatment 1415 ! ! = I : sea-ice velocity at F-point with index shift 1416 REAL(wp), INTENT( in ) :: & 1417 psgn ! control of the sign change 1418 ! ! = -1. , the sign is changed if north fold boundary 1419 ! ! = 1. , the sign is kept if north fold boundary 1420 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) :: & 1421 pt2d ! 2D array on which the boundary condition is applied 1422 1423 !! * Local variables 1424 INTEGER :: ji, jl ! dummy loop indices 1425 INTEGER :: & 1426 imigr, iihom, ijhom, & ! temporary integers 1427 iloc, ijt, iju ! " " 1428 INTEGER :: & 1429 ipreci, iprecj ! temporary integers 1430 INTEGER :: ml_req1, ml_req2, ml_err ! for isend 1431 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for isend 1432 !!--------------------------------------------------------------------- 1433 1434 ! take into account outer extra 2D overlap area 1435 ipreci = jpreci + jpr2di 1436 iprecj = jprecj + jpr2dj 1437 1438 1439 ! 1. standard boundary treatment 1440 ! ------------------------------ 1441 1442 ! ! East-West boundaries 1443 ! ! ==================== 1444 IF( nbondi == 2 .AND. & ! Cyclic east-west 1445 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1446 pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:) 1447 pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:) 1448 1449 ELSE ! ... closed 1450 SELECT CASE ( cd_type ) 1451 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1452 pt2d( 1-jpr2di :jpreci ,:) = 0.e0 1453 pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0 1454 CASE ( 'F' ) 1455 pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0 1456 END SELECT 1457 ENDIF 1458 1459 ! ! North-South boundaries 1460 ! ! ====================== 1461 SELECT CASE ( cd_type ) 1462 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1463 pt2d(:, 1-jpr2dj : jprecj ) = 0.e0 1464 pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0 1465 CASE ( 'F' ) 1466 pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0 1467 END SELECT 1468 1469 1470 ! 2. East and west directions 1471 ! --------------------------- 1472 1473 ! 2.1 Read Dirichlet lateral conditions 1474 1475 SELECT CASE ( nbondi ) 1476 CASE ( -1, 0, 1 ) ! all except 2 1477 iihom = nlci-nreci-jpr2di 1478 DO jl = 1, ipreci 1479 tr2ew(:,jl,1) = pt2d(jpreci+jl,:) 1480 tr2we(:,jl,1) = pt2d(iihom +jl,:) 1481 END DO 1482 END SELECT 1483 1484 ! 2.2 Migrations 1485 1486 #if defined key_mpp_shmem 1487 !! * SHMEM version 1488 1489 imigr = ipreci * ( jpj + 2*jpr2dj) 1490 1491 SELECT CASE ( nbondi ) 1492 CASE ( -1 ) 1493 CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea ) 1494 CASE ( 0 ) 1495 CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe ) 1496 CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea ) 1497 CASE ( 1 ) 1498 CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe ) 1499 END SELECT 1500 1501 CALL barrier() 1502 CALL shmem_udcflush() 1503 1504 #elif defined key_mpp_mpi 1505 !! * MPI version 1506 1507 imigr = ipreci * ( jpj + 2*jpr2dj) 1508 1509 SELECT CASE ( nbondi ) 1510 CASE ( -1 ) 1511 CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 1512 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 1513 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1514 CASE ( 0 ) 1515 CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 1516 CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 1517 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 1518 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 1519 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1520 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1521 CASE ( 1 ) 1522 CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 1523 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 1524 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1525 END SELECT 1526 1527 #endif 1528 1529 ! 2.3 Write Dirichlet lateral conditions 1530 1531 iihom = nlci - jpreci 1532 1533 SELECT CASE ( nbondi ) 1534 CASE ( -1 ) 1535 DO jl = 1, ipreci 1536 pt2d(iihom+jl,:) = tr2ew(:,jl,2) 1537 END DO 1538 CASE ( 0 ) 1539 DO jl = 1, ipreci 1540 pt2d(jl-jpr2di,:) = tr2we(:,jl,2) 1541 pt2d( iihom+jl,:) = tr2ew(:,jl,2) 1542 END DO 1543 CASE ( 1 ) 1544 DO jl = 1, ipreci 1545 pt2d(jl-jpr2di,:) = tr2we(:,jl,2) 1546 END DO 1547 END SELECT 1548 1549 1550 ! 3. North and south directions 1551 ! ----------------------------- 1552 1553 ! 3.1 Read Dirichlet lateral conditions 1554 1555 IF( nbondj /= 2 ) THEN 1556 ijhom = nlcj-nrecj-jpr2dj 1557 DO jl = 1, iprecj 1558 tr2sn(:,jl,1) = pt2d(:,ijhom +jl) 1559 tr2ns(:,jl,1) = pt2d(:,jprecj+jl) 1560 END DO 1561 ENDIF 1562 1563 ! 3.2 Migrations 1564 1565 #if defined key_mpp_shmem 1566 !! * SHMEM version 1567 1568 imigr = iprecj * ( jpi + 2*jpr2di ) 1569 1570 SELECT CASE ( nbondj ) 1571 CASE ( -1 ) 1572 CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono ) 1573 CASE ( 0 ) 1574 CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso ) 1575 CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono ) 1576 CASE ( 1 ) 1577 CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso ) 1578 END SELECT 1579 CALL barrier() 1580 CALL shmem_udcflush() 1581 1582 #elif defined key_mpp_mpi 1583 !! * MPI version 1584 1585 imigr = iprecj * ( jpi + 2*jpr2di ) 1586 1587 SELECT CASE ( nbondj ) 1588 CASE ( -1 ) 1589 CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 1590 CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 1591 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1592 CASE ( 0 ) 1593 CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 1594 CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 ) 1595 CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr ) 1596 CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 1597 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1598 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1599 CASE ( 1 ) 1600 CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 1601 CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr ) 1602 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1603 END SELECT 1604 1605 #endif 1606 1607 ! 3.3 Write Dirichlet lateral conditions 1608 1609 ijhom = nlcj - jprecj 1610 1611 SELECT CASE ( nbondj ) 1612 CASE ( -1 ) 1613 DO jl = 1, iprecj 1614 pt2d(:,ijhom+jl) = tr2ns(:,jl,2) 1615 END DO 1616 CASE ( 0 ) 1617 DO jl = 1, iprecj 1618 pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2) 1619 pt2d(:,ijhom+jl ) = tr2ns(:,jl,2) 1620 END DO 1621 CASE ( 1 ) 1622 DO jl = 1, iprecj 1623 pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2) 1624 END DO 1625 END SELECT 1626 1627 1628 ! 4. north fold treatment 1629 ! ----------------------- 1630 1631 ! 4.1 treatment without exchange (jpni odd) 1632 1633 SELECT CASE ( jpni ) 1634 1635 CASE ( 1 ) ! only one proc along I, no mpp exchange 1636 1637 SELECT CASE ( npolj ) 1638 1639 CASE ( 3 , 4 ) ! T pivot 1640 iloc = jpiglo - 2 * ( nimpp - 1 ) 1641 1642 SELECT CASE ( cd_type ) 1643 1644 CASE ( 'T', 'S', 'W' ) 1645 DO jl = 0, iprecj-1 1646 DO ji = 2-jpr2di, nlci+jpr2di 1647 ijt=iloc-ji+2 1648 pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl) 1649 END DO 1650 END DO 1651 DO ji = nlci/2+1, nlci+jpr2di 1652 ijt=iloc-ji+2 1653 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1) 1654 END DO 1655 1656 CASE ( 'U' ) 1657 DO jl =0, iprecj-1 1658 DO ji = 1-jpr2di, nlci-1-jpr2di 1659 iju=iloc-ji+1 1660 pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl) 1661 END DO 1662 END DO 1663 DO ji = nlci/2, nlci-1+jpr2di 1664 iju=iloc-ji+1 1665 pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1) 1666 END DO 1667 1668 CASE ( 'V' ) 1669 DO jl = -1, iprecj-1 1670 DO ji = 2-jpr2di, nlci+jpr2di 1671 ijt=iloc-ji+2 1672 pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-3-jl) 1673 END DO 1674 END DO 1675 1676 CASE ( 'F', 'G' ) 1677 DO jl = -1, iprecj-1 1678 DO ji = 1-jpr2di, nlci-1+jpr2di 1679 iju=iloc-ji+1 1680 pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-3-jl) 1681 END DO 1682 END DO 1683 1684 CASE ( 'I' ) ! ice U-V point 1685 DO jl = 0, iprecj-1 1686 pt2d(2,nlcj+jl) = psgn * pt2d(3,nlcj-1-jl) 1687 DO ji = 3, nlci+jpr2di 1688 iju = iloc - ji + 3 1689 pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl) 1690 END DO 1691 END DO 1692 1693 END SELECT 1694 1695 CASE ( 5 , 6 ) ! F pivot 1696 iloc=jpiglo-2*(nimpp-1) 1697 1698 SELECT CASE (cd_type ) 1699 1700 CASE ( 'T', 'S', 'W' ) 1701 DO jl = 0, iprecj-1 1702 DO ji = 1-jpr2di, nlci+jpr2di 1703 ijt=iloc-ji+1 1704 pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-1-jl) 1705 END DO 1706 END DO 1707 1708 CASE ( 'U' ) 1709 DO jl = 0, iprecj-1 1710 DO ji = 1-jpr2di, nlci-1+jpr2di 1711 iju=iloc-ji 1712 pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl) 1713 END DO 1714 END DO 1715 1716 CASE ( 'V' ) 1717 DO jl = 0, iprecj-1 1718 DO ji = 1-jpr2di, nlci+jpr2di 1719 ijt=iloc-ji+1 1720 pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl) 1721 END DO 1722 END DO 1723 DO ji = nlci/2+1, nlci+jpr2di 1724 ijt=iloc-ji+1 1725 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1) 1726 END DO 1727 1728 CASE ( 'F', 'G' ) 1729 DO jl = 0, iprecj-1 1730 DO ji = 1-jpr2di, nlci-1+jpr2di 1731 iju=iloc-ji 1732 pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl) 1733 END DO 1734 END DO 1735 DO ji = nlci/2+1, nlci-1+jpr2di 1736 iju=iloc-ji 1737 pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1) 1738 END DO 1739 1740 CASE ( 'I' ) ! ice U-V point 1741 pt2d( 2 ,nlcj) = 0.e0 1742 DO jl = 0, iprecj-1 1743 DO ji = 2 , nlci-1+jpr2di 1744 ijt = iloc - ji + 2 1745 pt2d(ji,nlcj+jl)= 0.5 * ( pt2d(ji,nlcj-1-jl) + psgn * pt2d(ijt,nlcj-1-jl) ) 1746 END DO 1747 END DO 1748 1749 END SELECT ! cd_type 1750 1751 END SELECT ! npolj 1752 1753 CASE DEFAULT ! more than 1 proc along I 1754 IF( npolj /= 0 ) CALL mpp_lbc_north_e( pt2d, cd_type, psgn ) ! only for northern procs 1755 1756 END SELECT ! jpni 1757 1758 1759 ! 5. East and west directions 1760 ! --------------------------- 1761 1762 SELECT CASE ( npolj ) 1763 1764 CASE ( 3, 4, 5, 6 ) 1765 1766 ! 5.1 Read Dirichlet lateral conditions 1767 1768 SELECT CASE ( nbondi ) 1769 CASE ( -1, 0, 1 ) 1770 iihom = nlci-nreci-jpr2di 1771 DO jl = 1, ipreci 1772 tr2ew(:,jl,1) = pt2d(jpreci+jl,:) 1773 tr2we(:,jl,1) = pt2d(iihom +jl,:) 1774 END DO 1775 END SELECT 1776 1777 ! 5.2 Migrations 1778 1779 #if defined key_mpp_shmem 1780 !! * SHMEM version 1781 1782 imigr = ipreci * ( jpj + 2*jpr2dj ) 1783 1784 SELECT CASE ( nbondi ) 1785 CASE ( -1 ) 1786 CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea ) 1787 CASE ( 0 ) 1788 CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe ) 1789 CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea ) 1790 CASE ( 1 ) 1791 CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe ) 1792 END SELECT 1793 1794 CALL barrier() 1795 CALL shmem_udcflush() 1796 1797 #elif defined key_mpp_mpi 1798 !! * MPI version 1799 1800 imigr=ipreci* ( jpj + 2*jpr2dj ) 1801 1802 SELECT CASE ( nbondi ) 1803 CASE ( -1 ) 1804 CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 1805 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 1806 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1807 CASE ( 0 ) 1808 CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 1809 CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 1810 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr ) 1811 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 1812 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1813 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1814 CASE ( 1 ) 1815 CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 1816 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr ) 1817 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1818 END SELECT 1819 #endif 1820 1821 ! 5.3 Write Dirichlet lateral conditions 1822 1823 iihom = nlci - jpreci 1824 1825 SELECT CASE ( nbondi ) 1826 CASE ( -1 ) 1827 DO jl = 1, ipreci 1828 pt2d(iihom+jl,:) = tr2ew(:,jl,2) 1829 END DO 1830 CASE ( 0 ) 1831 DO jl = 1, ipreci 1832 pt2d(jl- jpr2di,:) = tr2we(:,jl,2) 1833 pt2d(iihom+jl,:) = tr2ew(:,jl,2) 1834 END DO 1835 CASE ( 1 ) 1836 DO jl = 1, ipreci 1837 pt2d(jl-jpr2di,:) = tr2we(:,jl,2) 1838 END DO 1839 END SELECT 1840 1841 END SELECT ! npolj 1842 1843 END SUBROUTINE mpp_lnk_2d_e 1844 1845 1378 1846 SUBROUTINE mpplnks( ptab ) 1379 1847 !!---------------------------------------------------------------------- … … 3646 4114 3647 4115 4116 SUBROUTINE mpp_lbc_north_e ( pt2d, cd_type, psgn) 4117 !!--------------------------------------------------------------------- 4118 !! *** routine mpp_lbc_north_2d *** 4119 !! 4120 !! ** Purpose : 4121 !! Ensure proper north fold horizontal bondary condition in mpp configuration 4122 !! in case of jpn1 > 1 (for 2d array with outer extra halo) 4123 !! 4124 !! ** Method : 4125 !! Gather the 4+2*jpr2dj northern lines of the global domain on 1 processor and 4126 !! apply lbc north-fold on this sub array. Then scatter the fold array 4127 !! back to the processors. 4128 !! 4129 !! History : 4130 !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north 4131 !! from lbc routine 4132 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk 4133 !! 9.0 ! 05-09 (R. Benshila ) adapt mpp_lbc_north_2d 4134 !!---------------------------------------------------------------------- 4135 4136 !! * Arguments 4137 CHARACTER(len=1), INTENT( in ) :: & 4138 cd_type ! nature of pt2d grid-points 4139 ! ! = T , U , V , F or W gridpoints 4140 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) :: & 4141 pt2d ! 2D array on which the boundary condition is applied 4142 REAL(wp), INTENT( in ) :: & 4143 psgn ! control of the sign change 4144 ! ! = -1. , the sign is changed if north fold boundary 4145 ! ! = 1. , the sign is kept if north fold boundary 4146 4147 4148 !! * Local declarations 4149 4150 INTEGER :: ji, jj, jr, jproc, jl 4151 INTEGER :: ierr 4152 INTEGER :: ildi,ilei,iilb 4153 INTEGER :: ijpj,ijpjm1,ij,ijt,iju, iprecj 4154 INTEGER :: itaille 4155 4156 REAL(wp), DIMENSION(jpiglo,1-jpr2dj:4+jpr2dj) :: ztab 4157 REAL(wp), DIMENSION(jpi,1-jpr2dj:4+jpr2dj,jpni) :: znorthgloio 4158 REAL(wp), DIMENSION(jpi,1-jpr2dj:4+jpr2dj) :: znorthloc 4159 4160 ! If we get in this routine it s because : North fold condition and mpp with more 4161 ! than one proc across i : we deal only with the North condition 4162 4163 ! 0. Sign setting 4164 ! --------------- 4165 4166 ijpj=4 4167 ijpjm1=3 4168 iprecj = jpr2dj+jprecj 4169 4170 ! put in znorthloc the last 4 jlines of pt2d 4171 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 4172 ij = jj - nlcj + ijpj 4173 znorthloc(:,ij)=pt2d(1:jpi,jj) 4174 END DO 4175 4176 IF (npolj /= 0 ) THEN 4177 ! Build in proc 0 of ncomm_north the znorthgloio 4178 znorthgloio(:,:,:) = 0_wp 4179 #ifdef key_mpp_shmem 4180 not done : compiler error 4181 #elif defined key_mpp_mpi 4182 itaille=jpi*(ijpj+2*jpr2dj) 4183 CALL MPI_GATHER(znorthloc(1,1-jpr2dj),itaille,MPI_DOUBLE_PRECISION, & 4184 & znorthgloio(1,1-jpr2dj,1),itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr) 4185 #endif 4186 ENDIF 4187 4188 IF (narea == north_root+1 ) THEN 4189 ! recover the global north array 4190 ztab(:,:) = 0_wp 4191 4192 DO jr = 1, ndim_rank_north 4193 jproc=nrank_north(jr)+1 4194 ildi=nldit (jproc) 4195 ilei=nleit (jproc) 4196 iilb=nimppt(jproc) 4197 DO jj=1-jpr2dj,ijpj+jpr2dj 4198 DO ji=ildi,ilei 4199 ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr) 4200 END DO 4201 END DO 4202 END DO 4203 4204 4205 ! 2. North-Fold boundary conditions 4206 ! ---------------------------------- 4207 4208 SELECT CASE ( npolj ) 4209 4210 CASE ( 3, 4 ) ! * North fold T-point pivot 4211 4212 ztab( 1 ,ijpj:ijpj+jpr2dj) = 0.e0 4213 ztab(jpiglo,ijpj:ijpj+jpr2dj) = 0.e0 4214 4215 SELECT CASE ( cd_type ) 4216 4217 CASE ( 'T' , 'W' , 'S' ) ! T-, W-point 4218 DO jl =0, iprecj-1 4219 DO ji = 2, jpiglo 4220 ijt = jpiglo-ji+2 4221 ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-2-jl) 4222 END DO 4223 END DO 4224 DO ji = jpiglo/2+1, jpiglo 4225 ijt = jpiglo-ji+2 4226 ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1) 4227 END DO 4228 4229 CASE ( 'U' ) ! U-point 4230 DO jl =0, iprecj-1 4231 DO ji = 1, jpiglo-1 4232 iju = jpiglo-ji+1 4233 ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-2-jl) 4234 END DO 4235 END DO 4236 DO ji = jpiglo/2, jpiglo-1 4237 iju = jpiglo-ji+1 4238 ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1) 4239 END DO 4240 4241 CASE ( 'V' ) ! V-point 4242 DO jl =-1, iprecj-1 4243 DO ji = 2, jpiglo 4244 ijt = jpiglo-ji+2 4245 ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-3-jl) 4246 END DO 4247 END DO 4248 4249 CASE ( 'F' , 'G' ) ! F-point 4250 DO jl =-1, iprecj-1 4251 DO ji = 1, jpiglo-1 4252 iju = jpiglo-ji+1 4253 ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-3-jl) 4254 END DO 4255 END DO 4256 4257 CASE ( 'I' ) ! ice U-V point 4258 DO jl =0, iprecj-1 4259 ztab(2,ijpj+jl) = psgn * ztab(3,ijpj-1+jl) 4260 DO ji = 3, jpiglo 4261 iju = jpiglo - ji + 3 4262 ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-1-jl) 4263 END DO 4264 END DO 4265 4266 END SELECT 4267 4268 CASE ( 5, 6 ) ! * North fold F-point pivot 4269 4270 ztab( 1 ,ijpj:ijpj+jpr2dj) = 0.e0 4271 ztab(jpiglo,ijpj:ijpj+jpr2dj) = 0.e0 4272 4273 SELECT CASE ( cd_type ) 4274 4275 CASE ( 'T' , 'W' ,'S' ) ! T-, W-point 4276 DO jl = 0, iprecj-1 4277 DO ji = 1, jpiglo 4278 ijt = jpiglo-ji+1 4279 ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-1-jl) 4280 END DO 4281 END DO 4282 4283 CASE ( 'U' ) ! U-point 4284 DO jl = 0, iprecj-1 4285 DO ji = 1, jpiglo-1 4286 iju = jpiglo-ji 4287 ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-1-jl) 4288 END DO 4289 END DO 4290 4291 CASE ( 'V' ) ! V-point 4292 DO jl = 0, iprecj-1 4293 DO ji = 1, jpiglo 4294 ijt = jpiglo-ji+1 4295 ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-2-jl) 4296 END DO 4297 END DO 4298 DO ji = jpiglo/2+1, jpiglo 4299 ijt = jpiglo-ji+1 4300 ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1) 4301 END DO 4302 4303 CASE ( 'F' , 'G' ) ! F-point 4304 DO jl = 0, iprecj-1 4305 DO ji = 1, jpiglo-1 4306 iju = jpiglo-ji 4307 ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-2-jl) 4308 END DO 4309 END DO 4310 DO ji = jpiglo/2+1, jpiglo-1 4311 iju = jpiglo-ji 4312 ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1) 4313 END DO 4314 4315 CASE ( 'I' ) ! ice U-V point 4316 ztab( 2 ,ijpj:ijpj+jpr2dj) = 0.e0 4317 DO jl = 0, jpr2dj 4318 DO ji = 2 , jpiglo-1 4319 ijt = jpi - ji + 2 4320 ztab(ji,ijpj+jl)= 0.5 * ( ztab(ji,ijpj-1-jl) + psgn * ztab(ijt,ijpj-1-jl) ) 4321 END DO 4322 END DO 4323 4324 END SELECT 4325 4326 CASE DEFAULT ! * closed : the code probably never go through 4327 4328 SELECT CASE ( cd_type) 4329 4330 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 4331 ztab(:, 1:1-jpr2dj ) = 0.e0 4332 ztab(:,ijpj:ijpj+jpr2dj) = 0.e0 4333 4334 CASE ( 'F' ) ! F-point 4335 ztab(:,ijpj:ijpj+jpr2dj) = 0.e0 4336 4337 CASE ( 'I' ) ! ice U-V point 4338 ztab(:, 1:1-jpr2dj ) = 0.e0 4339 ztab(:,ijpj:ijpj+jpr2dj) = 0.e0 4340 4341 END SELECT 4342 4343 END SELECT 4344 4345 ! End of slab 4346 ! =========== 4347 4348 !! Scatter back to pt2d 4349 DO jr = 1, ndim_rank_north 4350 jproc=nrank_north(jr)+1 4351 ildi=nldit (jproc) 4352 ilei=nleit (jproc) 4353 iilb=nimppt(jproc) 4354 DO jj=1-jpr2dj,ijpj+jpr2dj 4355 DO ji=ildi,ilei 4356 znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj) 4357 END DO 4358 END DO 4359 END DO 4360 4361 ENDIF ! only done on proc 0 of ncomm_north 4362 4363 #ifdef key_mpp_shmem 4364 not done yet in shmem : compiler error 4365 #elif key_mpp_mpi 4366 IF ( npolj /= 0 ) THEN 4367 itaille=jpi*(ijpj+2*jpr2dj) 4368 CALL MPI_SCATTER(znorthgloio(1,1-jpr2dj,1),itaille,MPI_DOUBLE_PRECISION, & 4369 & znorthloc(1,1-jpr2dj),itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr) 4370 ENDIF 4371 #endif 4372 4373 ! put in the last ijpj jlines of pt2d znorthloc 4374 DO jj = nlcj - ijpj -jpr2dj + 1 , nlcj +jpr2dj 4375 ij = jj - nlcj + ijpj 4376 pt2d(1:jpi,jj)= znorthloc(:,ij) 4377 END DO 4378 4379 END SUBROUTINE mpp_lbc_north_e 4380 4381 3648 4382 !!!!! 3649 4383 -
trunk/NEMO/OPA_SRC/par_oce.F90
r294 r311 29 29 jpnij = 1, & !: nb of local domain = nb of processors 30 30 ! ! ( <= jpni x jpnj ) 31 jpr2di = 0, & !: number of columns for extra outer halo 32 jpr2dj = 0, & !: number of rows for extra outer halo 31 33 jpreci = 1, & !: number of columns for overlap 32 34 jprecj = 1 !: number of rows for overlap -
trunk/NEMO/OPA_SRC/restart.F90
r295 r311 83 83 REAL(wp), DIMENSION( 1) :: zfice, zfblk ! used only in case of ice & bulk 84 84 REAL(wp), DIMENSION(10) :: zinfo(10) 85 REAL(wp), DIMENSION(jpi,jpj) :: ztab 85 86 !!---------------------------------------------------------------------- 86 87 !! OPA 9.0 , LOCEAN-IPSL (2005) … … 159 160 CALL restput( numwrs, 'hdivn' , jpi, jpj, jpk, 0, hdivn ) 160 161 161 CALL restput( numwrs, 'gcx' , jpi, jpj, 1 , 0, gcx ) ! Read elliptic solver arrays 162 CALL restput( numwrs, 'gcxb' , jpi, jpj, 1 , 0, gcxb ) 162 ztab(:,:) = gcx(1:jpi,1:jpj) 163 CALL restput( numwrs, 'gcx' , jpi, jpj, 1 , 0, ztab ) ! Read elliptic solver arrays 164 ztab(:,:) = gcxb(1:jpi,1:jpj) 165 CALL restput( numwrs, 'gcxb' , jpi, jpj, 1 , 0, ztab ) 163 166 # if defined key_dynspg_fsc 164 167 CALL restput( numwrs, 'sshb' , jpi, jpj, 1 , 0, sshb ) ! free surface formulation (ssh) … … 243 246 REAL(wp) :: zdate0, zdt, zinfo(10) 244 247 REAL(wp) :: zdept(jpk), zlamt(jpi,jpj), zphit(jpi,jpj) 248 REAL(wp), DIMENSION(jpi,jpj) :: ztab 245 249 # if defined key_ice_lim 246 250 INTEGER :: ios1, ji, jj, jn … … 346 350 CALL restget( inum, 'hdivn' , jpi, jpj, jpk, 0, llog, hdivn ) 347 351 348 CALL restget( inum, 'gcxb' , jpi, jpj, 1 , 0, llog, gcxb ) ! Read elliptic solver arrays 349 CALL restget( inum, 'gcx' , jpi, jpj, 1 , 0, llog, gcx ) 352 CALL restget( inum, 'gcxb' , jpi, jpj, 1 , 0, llog, ztab ) ! Read elliptic solver arrays 353 gcxb(1:jpi,1:jpj) = ztab(:,:) 354 CALL restget( inum, 'gcx' , jpi, jpj, 1 , 0, llog, ztab ) 355 gcx(1:jpi,1:jpj) = ztab(:,:) 350 356 # if defined key_dynspg_fsc 351 357 CALL restget( inum, 'sshb' , jpi, jpj, 1 , 0, llog, sshb ) ! free surface formulation (ssh) -
trunk/NEMO/OPA_SRC/restart_dimg.h90
r247 r311 166 166 167 167 ! elliptic solver arrays 168 WRITE(inum,REC=irec ) gcx( :,:)169 irec = irec +1 170 171 WRITE(inum,REC=irec ) gcxb( :,:)168 WRITE(inum,REC=irec ) gcx(1:jpi,1:jpj) 169 irec = irec +1 170 171 WRITE(inum,REC=irec ) gcxb(1:jpi,1:jpj) 172 172 irec = irec +1 173 173 … … 457 457 458 458 ! elliptic solver arrays 459 READ(inum,REC=irec ) gcx( :,:)460 irec = irec +1 461 462 READ(inum,REC=irec ) gcxb( :,:)459 READ(inum,REC=irec ) gcx(1:jpi,1:jpj) 460 irec = irec +1 461 462 READ(inum,REC=irec ) gcxb(1:jpi,1:jpj) 463 463 irec = irec +1 464 464
Note: See TracChangeset
for help on using the changeset viewer.
