- Timestamp:
- 2015-12-16T16:44:35+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r6060 r6069 72 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 73 PUBLIC mpp_lnk_2d_9 74 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 74 75 PUBLIC mppscatter, mppgather 75 76 PUBLIC mpp_ini_ice, mpp_ini_znl … … 1391 1392 END SUBROUTINE mpp_lnk_2d_e 1392 1393 1394 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 1395 !!---------------------------------------------------------------------- 1396 !! *** routine mpp_lnk_sum_3d *** 1397 !! 1398 !! ** Purpose : Message passing manadgement (sum the overlap region) 1399 !! 1400 !! ** Method : Use mppsend and mpprecv function for passing mask 1401 !! between processors following neighboring subdomains. 1402 !! domain parameters 1403 !! nlci : first dimension of the local subdomain 1404 !! nlcj : second dimension of the local subdomain 1405 !! nbondi : mark for "east-west local boundary" 1406 !! nbondj : mark for "north-south local boundary" 1407 !! noea : number for local neighboring processors 1408 !! nowe : number for local neighboring processors 1409 !! noso : number for local neighboring processors 1410 !! nono : number for local neighboring processors 1411 !! 1412 !! ** Action : ptab with update value at its periphery 1413 !! 1414 !!---------------------------------------------------------------------- 1415 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 1416 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1417 ! ! = T , U , V , F , W points 1418 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1419 ! ! = 1. , the sign is kept 1420 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1421 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1422 !! 1423 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1424 INTEGER :: imigr, iihom, ijhom ! temporary integers 1425 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1426 REAL(wp) :: zland 1427 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1428 ! 1429 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 1430 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 1431 1432 !!---------------------------------------------------------------------- 1433 1434 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 1435 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 1436 1437 ! 1438 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1439 ELSE ; zland = 0.e0 ! zero by default 1440 ENDIF 1441 1442 ! 1. standard boundary treatment 1443 ! ------------------------------ 1444 ! 2. East and west directions exchange 1445 ! ------------------------------------ 1446 ! we play with the neigbours AND the row number because of the periodicity 1447 ! 1448 SELECT CASE ( nbondi ) ! Read lateral conditions 1449 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1450 iihom = nlci-jpreci 1451 DO jl = 1, jpreci 1452 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0.0_wp 1453 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp 1454 END DO 1455 END SELECT 1456 ! 1457 ! ! Migrations 1458 imigr = jpreci * jpj * jpk 1459 ! 1460 SELECT CASE ( nbondi ) 1461 CASE ( -1 ) 1462 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 1463 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1464 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1465 CASE ( 0 ) 1466 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1467 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 1468 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1469 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1470 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1471 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1472 CASE ( 1 ) 1473 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1474 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1475 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1476 END SELECT 1477 ! 1478 ! ! Write lateral conditions 1479 iihom = nlci-nreci 1480 ! 1481 SELECT CASE ( nbondi ) 1482 CASE ( -1 ) 1483 DO jl = 1, jpreci 1484 ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 1485 END DO 1486 CASE ( 0 ) 1487 DO jl = 1, jpreci 1488 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1489 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 1490 END DO 1491 CASE ( 1 ) 1492 DO jl = 1, jpreci 1493 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1494 END DO 1495 END SELECT 1496 1497 1498 ! 3. North and south directions 1499 ! ----------------------------- 1500 ! always closed : we play only with the neigbours 1501 ! 1502 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1503 ijhom = nlcj-jprecj 1504 DO jl = 1, jprecj 1505 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 1506 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp 1507 END DO 1508 ENDIF 1509 ! 1510 ! ! Migrations 1511 imigr = jprecj * jpi * jpk 1512 ! 1513 SELECT CASE ( nbondj ) 1514 CASE ( -1 ) 1515 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 1516 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1517 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1518 CASE ( 0 ) 1519 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1520 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 1521 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1522 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1523 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1524 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1525 CASE ( 1 ) 1526 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1527 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1528 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1529 END SELECT 1530 ! 1531 ! ! Write lateral conditions 1532 ijhom = nlcj-nrecj 1533 ! 1534 SELECT CASE ( nbondj ) 1535 CASE ( -1 ) 1536 DO jl = 1, jprecj 1537 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 1538 END DO 1539 CASE ( 0 ) 1540 DO jl = 1, jprecj 1541 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 1542 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 1543 END DO 1544 CASE ( 1 ) 1545 DO jl = 1, jprecj 1546 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2) 1547 END DO 1548 END SELECT 1549 1550 1551 ! 4. north fold treatment 1552 ! ----------------------- 1553 ! 1554 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1555 ! 1556 SELECT CASE ( jpni ) 1557 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 1558 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 1559 END SELECT 1560 ! 1561 ENDIF 1562 ! 1563 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 1564 ! 1565 END SUBROUTINE mpp_lnk_sum_3d 1566 1567 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 1568 !!---------------------------------------------------------------------- 1569 !! *** routine mpp_lnk_sum_2d *** 1570 !! 1571 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region) 1572 !! 1573 !! ** Method : Use mppsend and mpprecv function for passing mask 1574 !! between processors following neighboring subdomains. 1575 !! domain parameters 1576 !! nlci : first dimension of the local subdomain 1577 !! nlcj : second dimension of the local subdomain 1578 !! nbondi : mark for "east-west local boundary" 1579 !! nbondj : mark for "north-south local boundary" 1580 !! noea : number for local neighboring processors 1581 !! nowe : number for local neighboring processors 1582 !! noso : number for local neighboring processors 1583 !! nono : number for local neighboring processors 1584 !! 1585 !!---------------------------------------------------------------------- 1586 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 1587 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1588 ! ! = T , U , V , F , W and I points 1589 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1590 ! ! = 1. , the sign is kept 1591 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1592 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1593 !! 1594 INTEGER :: ji, jj, jl ! dummy loop indices 1595 INTEGER :: imigr, iihom, ijhom ! temporary integers 1596 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1597 REAL(wp) :: zland 1598 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1599 ! 1600 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 1601 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 1602 1603 !!---------------------------------------------------------------------- 1604 1605 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 1606 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 1607 1608 ! 1609 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1610 ELSE ; zland = 0.e0 ! zero by default 1611 ENDIF 1612 1613 ! 1. standard boundary treatment 1614 ! ------------------------------ 1615 ! 2. East and west directions exchange 1616 ! ------------------------------------ 1617 ! we play with the neigbours AND the row number because of the periodicity 1618 ! 1619 SELECT CASE ( nbondi ) ! Read lateral conditions 1620 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1621 iihom = nlci - jpreci 1622 DO jl = 1, jpreci 1623 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp 1624 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 1625 END DO 1626 END SELECT 1627 ! 1628 ! ! Migrations 1629 imigr = jpreci * jpj 1630 ! 1631 SELECT CASE ( nbondi ) 1632 CASE ( -1 ) 1633 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 1634 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1635 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1636 CASE ( 0 ) 1637 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1638 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 1639 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1640 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1641 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1642 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1643 CASE ( 1 ) 1644 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1645 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1646 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1647 END SELECT 1648 ! 1649 ! ! Write lateral conditions 1650 iihom = nlci-nreci 1651 ! 1652 SELECT CASE ( nbondi ) 1653 CASE ( -1 ) 1654 DO jl = 1, jpreci 1655 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 1656 END DO 1657 CASE ( 0 ) 1658 DO jl = 1, jpreci 1659 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1660 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 1661 END DO 1662 CASE ( 1 ) 1663 DO jl = 1, jpreci 1664 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1665 END DO 1666 END SELECT 1667 1668 1669 ! 3. North and south directions 1670 ! ----------------------------- 1671 ! always closed : we play only with the neigbours 1672 ! 1673 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1674 ijhom = nlcj - jprecj 1675 DO jl = 1, jprecj 1676 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 1677 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp 1678 END DO 1679 ENDIF 1680 ! 1681 ! ! Migrations 1682 imigr = jprecj * jpi 1683 ! 1684 SELECT CASE ( nbondj ) 1685 CASE ( -1 ) 1686 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 1687 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1688 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1689 CASE ( 0 ) 1690 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1691 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 1692 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1693 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1695 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1696 CASE ( 1 ) 1697 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1698 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1699 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1700 END SELECT 1701 ! 1702 ! ! Write lateral conditions 1703 ijhom = nlcj-nrecj 1704 ! 1705 SELECT CASE ( nbondj ) 1706 CASE ( -1 ) 1707 DO jl = 1, jprecj 1708 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 1709 END DO 1710 CASE ( 0 ) 1711 DO jl = 1, jprecj 1712 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1713 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 1714 END DO 1715 CASE ( 1 ) 1716 DO jl = 1, jprecj 1717 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1718 END DO 1719 END SELECT 1720 1721 1722 ! 4. north fold treatment 1723 ! ----------------------- 1724 ! 1725 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1726 ! 1727 SELECT CASE ( jpni ) 1728 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1729 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 1730 END SELECT 1731 ! 1732 ENDIF 1733 ! 1734 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1735 ! 1736 END SUBROUTINE mpp_lnk_sum_2d 1393 1737 1394 1738 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
Note: See TracChangeset
for help on using the changeset viewer.
