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