- Timestamp:
- 2011-07-11T12:53:56+02:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r2731 r2797 47 47 !! mppsync : 48 48 !! mppstop : 49 !! mppobc : variant of mpp_lnk for open boundary condition50 49 !! mpp_ini_north : initialisation of north fold 51 50 !! mpp_lbc_north : north fold processors gathering … … 64 63 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 65 64 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 66 PUBLIC mpp obc, mpp_ini_ice, mpp_ini_znl65 PUBLIC mpp_ini_ice, mpp_ini_znl 67 66 PUBLIC mppsize 68 67 PUBLIC lib_mpp_alloc ! Called in nemogcm.F90 … … 1726 1725 END SUBROUTINE mppstop 1727 1726 1728 1729 SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)1730 !!----------------------------------------------------------------------1731 !! *** routine mppobc ***1732 !!1733 !! ** Purpose : Message passing manadgement for open boundary1734 !! conditions array1735 !!1736 !! ** Method : Use mppsend and mpprecv function for passing mask1737 !! between processors following neighboring subdomains.1738 !! domain parameters1739 !! nlci : first dimension of the local subdomain1740 !! nlcj : second dimension of the local subdomain1741 !! nbondi : mark for "east-west local boundary"1742 !! nbondj : mark for "north-south local boundary"1743 !! noea : number for local neighboring processors1744 !! nowe : number for local neighboring processors1745 !! noso : number for local neighboring processors1746 !! nono : number for local neighboring processors1747 !!1748 !!----------------------------------------------------------------------1749 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released1750 USE wrk_nemo, ONLY: ztab => wrk_2d_11751 !1752 INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices1753 INTEGER , INTENT(in ) :: kl ! index of open boundary1754 INTEGER , INTENT(in ) :: kk ! vertical dimension1755 INTEGER , INTENT(in ) :: ktype ! define north/south or east/west cdt1756 ! ! = 1 north/south ; = 2 east/west1757 INTEGER , INTENT(in ) :: kij ! horizontal dimension1758 INTEGER , INTENT(in ) :: kumout ! ocean.output logical unit1759 REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array1760 !1761 INTEGER :: ji, jj, jk, jl ! dummy loop indices1762 INTEGER :: iipt0, iipt1, ilpt1 ! local integers1763 INTEGER :: ijpt0, ijpt1 ! - -1764 INTEGER :: imigr, iihom, ijhom ! - -1765 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1766 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend1767 !!----------------------------------------------------------------------1768 1769 IF( wrk_in_use(2, 1) ) THEN1770 WRITE(kumout, cform_err)1771 WRITE(kumout,*) 'mppobc : requested workspace array unavailable'1772 CALL mppstop1773 ENDIF1774 1775 ! boundary condition initialization1776 ! ---------------------------------1777 ztab(:,:) = 0.e01778 !1779 IF( ktype==1 ) THEN ! north/south boundaries1780 iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )1781 iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )1782 ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )1783 ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )1784 ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )1785 ELSEIF( ktype==2 ) THEN ! east/west boundaries1786 iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )1787 iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )1788 ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )1789 ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )1790 ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )1791 ELSE1792 WRITE(kumout, cform_err)1793 WRITE(kumout,*) 'mppobc : bad ktype'1794 CALL mppstop1795 ENDIF1796 1797 ! Communication level by level1798 ! ----------------------------1799 !!gm Remark : this is very time consumming!!!1800 ! ! ------------------------ !1801 DO jk = 1, kk ! Loop over the levels !1802 ! ! ------------------------ !1803 !1804 IF( ktype == 1 ) THEN ! north/south boundaries1805 DO jj = ijpt0, ijpt11806 DO ji = iipt0, iipt11807 ztab(ji,jj) = ptab(ji,jk)1808 END DO1809 END DO1810 ELSEIF( ktype == 2 ) THEN ! east/west boundaries1811 DO jj = ijpt0, ijpt11812 DO ji = iipt0, iipt11813 ztab(ji,jj) = ptab(jj,jk)1814 END DO1815 END DO1816 ENDIF1817 1818 1819 ! 1. East and west directions1820 ! ---------------------------1821 !1822 IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions1823 iihom = nlci-nreci1824 DO jl = 1, jpreci1825 t2ew(:,jl,1) = ztab(jpreci+jl,:)1826 t2we(:,jl,1) = ztab(iihom +jl,:)1827 END DO1828 ENDIF1829 !1830 ! ! Migrations1831 imigr=jpreci*jpj1832 !1833 IF( nbondi == -1 ) THEN1834 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )1835 CALL mpprecv( 1, t2ew(1,1,2), imigr )1836 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1837 ELSEIF( nbondi == 0 ) THEN1838 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )1839 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )1840 CALL mpprecv( 1, t2ew(1,1,2), imigr )1841 CALL mpprecv( 2, t2we(1,1,2), imigr )1842 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1843 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )1844 ELSEIF( nbondi == 1 ) THEN1845 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )1846 CALL mpprecv( 2, t2we(1,1,2), imigr )1847 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1848 ENDIF1849 !1850 ! ! Write Dirichlet lateral conditions1851 iihom = nlci-jpreci1852 !1853 IF( nbondi == 0 .OR. nbondi == 1 ) THEN1854 DO jl = 1, jpreci1855 ztab(jl,:) = t2we(:,jl,2)1856 END DO1857 ENDIF1858 IF( nbondi == -1 .OR. nbondi == 0 ) THEN1859 DO jl = 1, jpreci1860 ztab(iihom+jl,:) = t2ew(:,jl,2)1861 END DO1862 ENDIF1863 1864 1865 ! 2. North and south directions1866 ! -----------------------------1867 !1868 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1869 ijhom = nlcj-nrecj1870 DO jl = 1, jprecj1871 t2sn(:,jl,1) = ztab(:,ijhom +jl)1872 t2ns(:,jl,1) = ztab(:,jprecj+jl)1873 END DO1874 ENDIF1875 !1876 ! ! Migrations1877 imigr = jprecj * jpi1878 !1879 IF( nbondj == -1 ) THEN1880 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )1881 CALL mpprecv( 3, t2ns(1,1,2), imigr )1882 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1883 ELSEIF( nbondj == 0 ) THEN1884 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )1885 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )1886 CALL mpprecv( 3, t2ns(1,1,2), imigr )1887 CALL mpprecv( 4, t2sn(1,1,2), imigr )1888 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )1889 IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )1890 ELSEIF( nbondj == 1 ) THEN1891 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )1892 CALL mpprecv( 4, t2sn(1,1,2), imigr)1893 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )1894 ENDIF1895 !1896 ! ! Write Dirichlet lateral conditions1897 ijhom = nlcj - jprecj1898 IF( nbondj == 0 .OR. nbondj == 1 ) THEN1899 DO jl = 1, jprecj1900 ztab(:,jl) = t2sn(:,jl,2)1901 END DO1902 ENDIF1903 IF( nbondj == 0 .OR. nbondj == -1 ) THEN1904 DO jl = 1, jprecj1905 ztab(:,ijhom+jl) = t2ns(:,jl,2)1906 END DO1907 ENDIF1908 IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN1909 DO jj = ijpt0, ijpt1 ! north/south boundaries1910 DO ji = iipt0,ilpt11911 ptab(ji,jk) = ztab(ji,jj)1912 END DO1913 END DO1914 ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN1915 DO jj = ijpt0, ilpt1 ! east/west boundaries1916 DO ji = iipt0,iipt11917 ptab(jj,jk) = ztab(ji,jj)1918 END DO1919 END DO1920 ENDIF1921 !1922 END DO1923 !1924 IF( wrk_not_released(2, 1) ) THEN1925 WRITE(kumout, cform_err)1926 WRITE(kumout,*) 'mppobc : failed to release workspace array'1927 CALL mppstop1928 ENDIF1929 !1930 END SUBROUTINE mppobc1931 1932 1933 1727 SUBROUTINE mpp_comm_free( kcom ) 1934 1728 !!---------------------------------------------------------------------- … … 2488 2282 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 2489 2283 END INTERFACE 2490 INTERFACE mppobc2491 MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d2492 END INTERFACE2493 2284 INTERFACE mpp_minloc 2494 2285 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 2603 2394 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 2604 2395 END SUBROUTINE mppmin_int 2605 2606 SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2607 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2608 REAL, DIMENSION(:) :: parr ! variable array2609 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum2610 END SUBROUTINE mppobc_1d2611 2612 SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2613 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2614 REAL, DIMENSION(:,:) :: parr ! variable array2615 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum2616 END SUBROUTINE mppobc_2d2617 2618 SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2619 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2620 REAL, DIMENSION(:,:,:) :: parr ! variable array2621 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum2622 END SUBROUTINE mppobc_3d2623 2624 SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2625 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2626 REAL, DIMENSION(:,:,:,:) :: parr ! variable array2627 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum2628 END SUBROUTINE mppobc_4d2629 2396 2630 2397 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
Note: See TracChangeset
for help on using the changeset viewer.
