1338
1339
1342
1344# ifdef DISTRIBUTE
1346# endif
1347
1348
1349
1350 integer, intent(in) :: ng, tile, model, boundary
1351 integer, intent(in) :: edge(4)
1352 integer, intent(in) :: LBij, UBij
1353 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
1354 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
1355 integer, intent(in) :: Nghost, NHsteps, NVsteps
1356
1357 real(r8), intent(in) :: DTsizeH, DTsizeV
1358
1359# ifdef ASSUMED_SHAPE
1360 real(r8), intent(in) :: pm(LBi:,LBj:)
1361 real(r8), intent(in) :: pn(LBi:,LBj:)
1362 real(r8), intent(in) :: pmon_p(LBi:,LBj:)
1363 real(r8), intent(in) :: pnom_r(LBi:,LBj:)
1364# ifdef MASKING
1365 real(r8), intent(in) :: vmask(LBi:,LBj:)
1366 real(r8), intent(in) :: pmask(LBi:,LBj:)
1367# endif
1368 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
1369 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
1370
1371 real(r8), intent(in) :: Kh(LBi:,LBj:)
1372 real(r8), intent(in) :: Kv(LBi:,LBj:,0:)
1373 real(r8), intent(inout) :: A(LBij:,LBk:)
1374# else
1375 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
1376 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
1377 real(r8), intent(in) :: pmon_p(LBi:UBi,LBj:UBj)
1378 real(r8), intent(in) :: pnom_r(LBi:UBi,LBj:UBj)
1379# ifdef MASKING
1380 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
1381 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
1382# endif
1383 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
1384 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
1385
1386 real(r8), intent(in) :: Kh(LBi:UBi,LBj:UBj)
1387 real(r8), intent(in) :: Kv(LBi:UBi,LBj:UBj,0:UBk)
1388 real(r8), intent(inout) :: A(LBij:UBij,LBk:UBk)
1389# endif
1390
1391
1392
1393 logical, dimension(4) :: Lconvolve
1394
1395 integer :: Nnew, Nold, Nsav, i, j, k, step
1396
1397 real(r8) :: cff, cff1
1398
1399 real(r8), dimension(LBij:UBij,LBk:UBk,2) :: Awrk
1400
1401 real(r8), dimension(JminS:JmaxS,LBk:UBk) :: FE
1402 real(r8), dimension(IminS:ImaxS,LBk:UBk) :: FX
1403 real(r8), dimension(LBij:UBij) :: Hfac
1404# ifdef VCONVOLUTION
1405# ifndef SPLINES_VCONV
1406 real(r8), dimension(LBij:UBij,0:N(ng)) :: FC
1407# endif
1408# if !defined IMPLICIT_VCONV || defined SPLINES_VCONV
1409 real(r8), dimension(LBij:UBij,N(ng)) :: oHz
1410# endif
1411# if defined IMPLICIT_VCONV || defined SPLINES_VCONV
1412 real(r8), dimension(LBij:UBij,0:N(ng)) :: BC
1413 real(r8), dimension(LBij:UBij,0:N(ng)) :: CF
1414 real(r8), dimension(LBij:UBij,0:N(ng)) :: DC
1415# ifdef SPLINES_VCONV
1416 real(r8), dimension(LBij:UBij,0:N(ng)) :: FC
1417# endif
1418# else
1419 real(r8), dimension(LBij:UBij,0:N(ng)) :: FS
1420# endif
1421# endif
1422
1423# include "set_bounds.h"
1424
1425
1426
1427
1428
1429
1434
1435
1436
1437
1438
1439 IF (lconvolve(boundary)) THEN
1440 cff=dtsizeh*0.25_r8
1441 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1442 i=edge(boundary)
1443 DO j=jstrv-1,jend+1
1444 hfac(j)=cff*(pm(i,j-1)+pm(i,j))*(pn(i,j-1)+pn(i,j))
1445# ifdef VCONVOLUTION
1446# ifndef SPLINES_VCONV
1449# ifdef IMPLICIT_VCONV
1450 fc(j,k)=-dtsizev*(kv(i,j-1,k)+kv(i,j,k))/ &
1451 & (z_r(i,j-1,k+1)+z_r(i,j,k+1)- &
1452 & z_r(i,j-1,k )-z_r(i,j,k ))
1453# else
1454 fc(j,k)=dtsizev*(kv(i,j-1,k)+kv(i,j,k))/ &
1455 & (z_r(i,j-1,k+1)+z_r(i,j,k+1)- &
1456 & z_r(i,j-1,k )-z_r(i,j,k ))
1457# endif
1458 END DO
1459 fc(j,0)=0.0_r8
1460# endif
1461# if !defined IMPLICIT_VCONV || defined SPLINES_VCONV
1463 ohz(j,k)=2.0_r8/(hz(i,j-1,k)+hz(i,j,k))
1464 END DO
1465# endif
1466# endif
1467 END DO
1468 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1469 j=edge(boundary)
1470 DO i=istr-1,iend+1
1471 hfac(i)=cff*(pm(i,j-1)+pm(i,j))*(pn(i,j-1)+pn(i,j))
1472# ifdef VCONVOLUTION
1473# ifndef SPLINES_VCONV
1476# ifdef IMPLICIT_VCONV
1477 fc(i,k)=-dtsizev*(kv(i,j-1,k)+kv(i,j,k))/ &
1478 & (z_r(i,j-1,k+1)+z_r(i,j,k+1)- &
1479 & z_r(i,j-1,k )-z_r(i,j,k ))
1480# else
1481 fc(i,k)=dtsizev*(kv(i,j-1,k)+kv(i,j,k))/ &
1482 & (z_r(i,j-1,k+1)+z_r(i,j,k+1)- &
1483 & z_r(i,j-1,k )-z_r(i,j,k ))
1484# endif
1485 END DO
1486 fc(i,0)=0.0_r8
1487# endif
1488# if !defined IMPLICIT_VCONV || defined SPLINES_VCONV
1490 ohz(i,k)=2.0_r8/(hz(i,j-1,k)+hz(i,j,k))
1491 END DO
1492# endif
1493# endif
1494 END DO
1495 END IF
1496 END IF
1497
1498
1499
1500 nold=1
1501 nnew=2
1502
1504 & lbij, ubij, 1,
n(ng), &
1505 & a)
1506# ifdef DISTRIBUTE
1508 & lbij, ubij, 1,
n(ng), &
1509 & nghost, &
1511 & a)
1512# endif
1513 IF (lconvolve(boundary)) THEN
1514 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1516 DO j=jstrv-1,jend+1
1517 awrk(j,k,nold)=a(j,k)
1518 END DO
1519 END DO
1520 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1522 DO i=istr-1,iend+1
1523 awrk(i,k,nold)=a(i,k)
1524 END DO
1525 END DO
1526 END IF
1527 END IF
1528
1529
1530
1531
1532
1533 DO step=1,nhsteps
1534
1535
1536
1537 IF (lconvolve(boundary)) THEN
1538 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1539 i=edge(boundary)
1541 DO j=jstrv-1,jend
1542 fe(j,k)=pnom_r(i,j)*kh(i,j)* &
1543 & (awrk(j+1,k,nold)- &
1544 & awrk(j ,k,nold))
1545 END DO
1546 END DO
1547 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1548 j=edge(boundary)
1550 DO i=istr,iend+1
1551 fx(i,k)=pmon_p(i,j)*0.25_r8*(kh(i-1,j )+kh(i,j )+ &
1552 & kh(i-1,j-1)+kh(i,j-1))* &
1553 & (awrk(i ,k,nold)- &
1554 & awrk(i-1,k,nold))
1555# ifdef MASKING
1556 fx(i,k)=fx(i,k)*pmask(i,j)
1557# endif
1558 END DO
1559 END DO
1560 END IF
1561 END IF
1562
1563
1564
1565 IF (lconvolve(boundary)) THEN
1566 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1568 DO j=jstrv,jend
1569 awrk(j,k,nnew)=awrk(j,k,nold)+ &
1570 & hfac(j)* &
1571 & (fe(j,k)-fe(j-1,k))
1572 END DO
1573 END DO
1574 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1576 DO i=istr,iend
1577 awrk(i,k,nnew)=awrk(i,k,nold)+ &
1578 & hfac(i)* &
1579 & (fx(i+1,k)-fx(i,k))
1580 END DO
1581 END DO
1582 END IF
1583 END IF
1584
1585
1586
1588 & lbij, ubij, 1,
n(ng), &
1589 & awrk(:,:,nnew))
1590# ifdef DISTRIBUTE
1592 & lbij, ubij, 1,
n(ng), &
1593 & nghost, &
1595 & awrk(:,:,nnew))
1596# endif
1597
1598
1599
1600 nsav=nold
1601 nold=nnew
1602 nnew=nsav
1603 END DO
1604
1605# ifdef VCONVOLUTION
1606# ifdef IMPLICIT_VCONV
1607# ifdef SPLINES_VCONV
1608
1609
1610
1611
1612
1613
1614 DO step=1,nvsteps
1615
1616
1617
1618
1619
1620 IF (lconvolve(boundary)) THEN
1621 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1622 i=edge(boundary)
1623 cff1=0.5_r8*(1.0_r8/6.0_r8)
1624 DO j=jstrv,jend
1626 fc(j,k)=cff1*(hz(i,j-1,k )+hz(i,j,k ))- &
1627 & dtsizev*kv(i,j,k-1)*ohz(j,k )
1628 cf(j,k)=cff1*(hz(i,j-1,k+1)+hz(i,j,k+1))- &
1629 & dtsizev*kv(i,j,k+1)*ohz(j,k+1)
1630 END DO
1631 cf(j,0)=0.0_r8
1632 dc(j,0)=0.0_r8
1633 END DO
1634 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1635 j=edge(boundary)
1636 cff1=0.5_r8*(1.0_r8/6.0_r8)
1637 DO i=istr,iend
1639 fc(i,k)=cff1*(hz(i,j-1,k )+hz(i,j,k ))- &
1640 & dtsizev*kv(i,j,k-1)*ohz(i,k )
1641 cf(i,k)=cff1*(hz(i,j-1,k+1)+hz(i,j,k+1))- &
1642 & dtsizev*kv(i,j,k+1)*ohz(i,k+1)
1643 END DO
1644 cf(i,0)=0.0_r8
1645 dc(i,0)=0.0_r8
1646 END DO
1647 END IF
1648
1649
1650
1651 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1652 i=edge(boundary)
1653 cff1=0.5_r8*(1.0_r8/3.0_r8)
1655 DO j=jstrv,jend
1656 bc(j,k)=cff1*(hz(i,j-1,k )+hz(i,j,k )+ &
1657 & hz(i,j-1,k+1)+hz(i,j,k+1))+ &
1658 & dtsizev*kv(i,j,k)* &
1659 & (ohz(j,k)+ohz(j,k+1))
1660 cff=1.0_r8/(bc(j,k)-fc(j,k)*cf(j,k-1))
1661 cf(j,k)=cff*cf(j,k)
1662 dc(j,k)=cff*(awrk(j,k+1,nold)- &
1663 & awrk(j,k ,nold)- &
1664 & fc(j,k)*dc(j,k-1))
1665 END DO
1666 END DO
1667 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1668 j=edge(boundary)
1669 cff1=0.5_r8*(1.0_r8/3.0_r8)
1671 DO i=istr,iend
1672 bc(i,k)=cff1*(hz(i,j-1,k )+hz(i,j,k )+ &
1673 & hz(i,j-1,k+1)+hz(i,j,k+1))+ &
1674 & dtsizev*kv(i,j,k)* &
1675 & (ohz(i,k)+ohz(i,k+1))
1676 cff=1.0_r8/(bc(i,k)-fc(i,k)*cf(i,k-1))
1677 cf(i,k)=cff*cf(i,k)
1678 dc(i,k)=cff*(awrk(i,k+1,nold)- &
1679 & awrk(i,k ,nold)- &
1680 & fc(i,k)*dc(i,k-1))
1681 END DO
1682 END DO
1683 END IF
1684
1685
1686
1687 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1688 i=edge(boundary)
1689 DO j=jstrv,jend
1691 END DO
1693 DO j=jstrv,jend
1694 dc(j,k)=dc(j,k)-cf(j,k)*dc(j,k+1)
1695 END DO
1696 END DO
1698 DO j=jstrv,jend
1699 dc(j,k)=dc(j,k)*kv(i,j,k)
1700 awrk(j,k,nnew)=awrk(j,k,nold)+ &
1701 & dtsizev*ohz(j,k)* &
1702 & (dc(j,k)-dc(j,k-1))
1703 END DO
1704 END DO
1705 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1706 j=edge(boundary)
1707 DO i=istr,iend
1709 END DO
1711 DO i=istr,iend
1712 dc(i,k)=dc(i,k)-cf(i,k)*dc(i,k+1)
1713 END DO
1714 END DO
1716 DO i=istr,iend
1717 dc(i,k)=dc(i,k)*kv(i,j,k)
1718 awrk(i,k,nnew)=awrk(i,k,nold)+ &
1719 & dtsizev*ohz(i,k)* &
1720 & (dc(i,k)-dc(i,k-1))
1721 END DO
1722 END DO
1723 END IF
1724 END IF
1725
1726
1727
1728 nsav=nold
1729 nold=nnew
1730 nnew=nsav
1731 END DO
1732
1733# else
1734
1735
1736
1737
1738
1739 DO step=1,nvsteps
1740
1741
1742
1743
1744 IF (lconvolve(boundary)) THEN
1745 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1746 i=edge(boundary)
1748 DO j=jstrv,jend
1749 cff=0.5_r8*(hz(i,j-1,k)+hz(i,j,k))
1750 bc(j,k)=cff-fc(j,k)-fc(j,k-1)
1751 dc(j,k)=awrk(j,k,nold)*cff
1752 END DO
1753 END DO
1754 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1755 j=edge(boundary)
1757 DO i=istr,iend
1758 cff=0.5_r8*(hz(i,j-1,k)+hz(i,j,k))
1759 bc(i,k)=cff-fc(i,k)-fc(i,k-1)
1760 dc(i,k)=awrk(i,k,nold)*cff
1761 END DO
1762 END DO
1763 END IF
1764
1765
1766
1767 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1768 DO j=jstrv,jend
1769 cff=1.0_r8/bc(j,1)
1770 cf(j,1)=cff*fc(j,1)
1771 dc(j,1)=cff*dc(j,1)
1772 END DO
1774 DO j=jstrv,jend
1775 cff=1.0_r8/(bc(j,k)-fc(j,k-1)*cf(j,k-1))
1776 cf(j,k)=cff*fc(j,k)
1777 dc(j,k)=cff*(dc(j,k)-fc(j,k-1)*dc(j,k-1))
1778 END DO
1779 END DO
1780 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1781 DO i=istr,iend
1782 cff=1.0_r8/bc(i,1)
1783 cf(i,1)=cff*fc(i,1)
1784 dc(i,1)=cff*dc(i,1)
1785 END DO
1787 DO i=istr,iend
1788 cff=1.0_r8/(bc(i,k)-fc(i,k-1)*cf(i,k-1))
1789 cf(i,k)=cff*fc(i,k)
1790 dc(i,k)=cff*(dc(i,k)-fc(i,k-1)*dc(i,k-1))
1791 END DO
1792 END DO
1793 END IF
1794
1795
1796
1797 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1798 i=edge(boundary)
1799 DO j=jstrv,jend
1800 dc(j,
n(ng))=(dc(j,
n(ng))- &
1801 & fc(j,
n(ng)-1)*dc(j,
n(ng)-1))/ &
1803 & fc(j,
n(ng)-1)*cf(j,
n(ng)-1))
1804 awrk(j,
n(ng),nnew)=dc(j,
n(ng))
1805# ifdef MASKING
1806 awrk(j,
n(ng),nnew)=awrk(j,
n(ng),nnew)*vmask(i,j)
1807# endif
1808 END DO
1810 DO j=jstrv,jend
1811 dc(j,k)=dc(j,k)-cf(j,k)*dc(j,k+1)
1812 awrk(j,k,nnew)=dc(j,k)
1813# ifdef MASKING
1814 awrk(j,k,nnew)=awrk(j,k,nnew)*vmask(i,j)
1815# endif
1816 END DO
1817 END DO
1818 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1819 j=edge(boundary)
1820 DO i=istr,iend
1821 dc(i,
n(ng))=(dc(i,
n(ng))- &
1822 & fc(i,
n(ng)-1)*dc(i,
n(ng)-1))/ &
1824 & fc(i,
n(ng)-1)*cf(i,
n(ng)-1))
1825 awrk(i,
n(ng),nnew)=dc(i,
n(ng))
1826# ifdef MASKING
1827 awrk(i,
n(ng),nnew)=awrk(i,
n(ng),nnew)*vmask(i,j)
1828# endif
1829 END DO
1831 DO i=istr,iend
1832 dc(i,k)=dc(i,k)-cf(i,k)*dc(i,k+1)
1833 awrk(i,k,nnew)=dc(i,k)
1834# ifdef MASKING
1835 awrk(i,k,nnew)=awrk(i,k,nnew)*vmask(i,j)
1836# endif
1837 END DO
1838 END DO
1839 END IF
1840 END IF
1841
1842
1843
1844 nsav=nold
1845 nold=nnew
1846 nnew=nsav
1847 END DO
1848# endif
1849
1850# else
1851
1852
1853
1854
1855
1856 DO step=1,nvsteps
1857
1858
1859
1860
1861 IF (lconvolve(boundary)) THEN
1862 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1863 i=edge(boundary)
1864 DO j=jstrv,jend
1866 fs(j,k)=fc(j,k)*(awrk(j,k+1,nold)- &
1867 & awrk(j,k ,nold))
1868# ifdef MASKING
1869 fs(j,k)=fs(j,k)*vmask(i,j)
1870# endif
1871 END DO
1872 fs(j,0)=0.0_r8
1874 END DO
1875 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1876 j=edge(boundary)
1877 DO i=istr,iend
1879 fs(i,k)=fc(i,k)*(awrk(i,k+1,nold)- &
1880 & awrk(i,k ,nold))
1881# ifdef MASKING
1882 fs(i,k)=fs(i,k)*vmask(i,j)
1883# endif
1884 END DO
1885 fs(i,0)=0.0_r8
1887 END DO
1888 END IF
1889
1890
1891
1892
1893 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1895 DO j=jstrv,jend
1896 awrk(j,k,nnew)=awrk(j,k,nold)+ &
1897 & ohz(j,k)*(fs(j,k )- &
1898 & fs(j,k-1))
1899 END DO
1900 END DO
1901 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1903 DO i=istr,iend
1904 awrk(i,k,nnew)=awrk(i,k,nold)+ &
1905 & ohz(i,k)*(fs(i,k )- &
1906 & fs(i,k-1))
1907 END DO
1908 END DO
1909 END IF
1910 END IF
1911
1912
1913
1914 nsav=nold
1915 nold=nnew
1916 nnew=nsav
1917 END DO
1918# endif
1919# endif
1920
1921
1922
1923
1924
1925 IF (lconvolve(boundary)) THEN
1926 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1928 DO j=jstrv,jend
1929 a(j,k)=awrk(j,k,nold)
1930 END DO
1931 END DO
1932 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1934 DO i=istr,iend
1935 a(i,k)=awrk(i,k,nold)
1936 END DO
1937 END DO
1938 END IF
1939 END IF
1941 & lbij, ubij, 1,
n(ng), &
1942 & a)
1943# ifdef DISTRIBUTE
1945 & lbij, ubij, 1,
n(ng), &
1946 & nghost, &
1948 & a)
1949# endif
1950
1951 RETURN
subroutine bc_v3d_bry_tile(ng, tile, boundary, lbij, ubij, lbk, ubk, a)