Changeset 3541
- Timestamp:
- Jul 3, 2019, 2:40:01 PM (5 years ago)
- Location:
- LMDZ6/trunk/libf/phylmd/dyn1d
- Files:
-
- 6 added
- 5 edited
-
1DUTILS.h (modified) (3 diffs)
-
1D_interp_cases.h (modified) (6 diffs)
-
1D_read_forc_cases.h (modified) (2 diffs)
-
lmdz1d.F90 (modified) (1 diff)
-
mod_1D_cases_read2.F90 (modified) (5 diffs)
-
mod_1D_cases_read_std.F90 (added)
-
old_1DUTILS_read_interp.h (added)
-
old_1D_interp_cases.h (added)
-
old_1D_read_forc_cases.h (added)
-
old_lmdz1d.F90 (added)
-
scm.F90 (added)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/phylmd/dyn1d/1DUTILS.h
r3540 r3541 1460 1460 1461 1461 !====================================================================== 1462 SUBROUTINE read_togacoare(fich_toga,nlev_toga,nt_toga &1463 & ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga &1464 & ,ht_toga,vt_toga,hq_toga,vq_toga)1465 implicit none1466 1467 !-------------------------------------------------------------------------1468 ! Read TOGA-COARE forcing data1469 !-------------------------------------------------------------------------1470 1471 integer nlev_toga,nt_toga1472 real ts_toga(nt_toga),plev_toga(nlev_toga,nt_toga)1473 real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)1474 real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)1475 real w_toga(nlev_toga,nt_toga)1476 real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)1477 real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)1478 character*80 fich_toga1479 1480 integer k,ip1481 real bid1482 1483 integer iy,im,id,ih1484 1485 real plev_min1486 1487 plev_min = 55. ! pas de tendance de vap. d eau au-dessus de 55 hPa1488 1489 open(21,file=trim(fich_toga),form='formatted')1490 read(21,'(a)')1491 do ip = 1, nt_toga1492 read(21,'(a)')1493 read(21,'(a)')1494 read(21,223) iy, im, id, ih, bid, ts_toga(ip), bid,bid,bid,bid1495 read(21,'(a)')1496 read(21,'(a)')1497 1498 do k = 1, nlev_toga1499 read(21,230) plev_toga(k,ip), t_toga(k,ip), q_toga(k,ip) &1500 & ,u_toga(k,ip), v_toga(k,ip), w_toga(k,ip) &1501 & ,ht_toga(k,ip), vt_toga(k,ip), hq_toga(k,ip), vq_toga(k,ip)1502 1503 ! conversion in SI units:1504 t_toga(k,ip)=t_toga(k,ip)+273.15 ! K1505 q_toga(k,ip)=q_toga(k,ip)*0.001 ! kg/kg1506 w_toga(k,ip)=w_toga(k,ip)*100./3600. ! Pa/s1507 ! no water vapour tendency above 55 hPa1508 if (plev_toga(k,ip) .lt. plev_min) then1509 q_toga(k,ip) = 0.1510 hq_toga(k,ip) = 0.1511 vq_toga(k,ip) =0.1512 endif1513 enddo1514 1515 ts_toga(ip)=ts_toga(ip)+273.15 ! K1516 enddo1517 close(21)1518 1519 223 format(4i3,6f8.2)1520 230 format(6f9.3,4e11.3)1521 1522 return1523 end1524 1525 !-------------------------------------------------------------------------1526 SUBROUTINE read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)1527 implicit none1528 1529 !-------------------------------------------------------------------------1530 ! Read I.SANDU case forcing data1531 !-------------------------------------------------------------------------1532 1533 integer nlev_sandu,nt_sandu1534 real ts_sandu(nt_sandu)1535 character*80 fich_sandu1536 1537 integer ip1538 integer iy,im,id,ih1539 1540 real plev_min1541 1542 print*,'nlev_sandu',nlev_sandu1543 plev_min = 55000. ! pas de tendance de vap. d eau au-dessus de 55 hPa1544 1545 open(21,file=trim(fich_sandu),form='formatted')1546 read(21,'(a)')1547 do ip = 1, nt_sandu1548 read(21,'(a)')1549 read(21,'(a)')1550 read(21,223) iy, im, id, ih, ts_sandu(ip)1551 print *,'ts=',iy,im,id,ih,ip,ts_sandu(ip)1552 enddo1553 close(21)1554 1555 223 format(4i3,f8.2)1556 1557 return1558 end1559 1560 !=====================================================================1561 !-------------------------------------------------------------------------1562 SUBROUTINE read_astex(fich_astex,nlev_astex,nt_astex,div_astex, &1563 & ts_astex,ug_astex,vg_astex,ufa_astex,vfa_astex)1564 implicit none1565 1566 !-------------------------------------------------------------------------1567 ! Read Astex case forcing data1568 !-------------------------------------------------------------------------1569 1570 integer nlev_astex,nt_astex1571 real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)1572 real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)1573 character*80 fich_astex1574 1575 integer ip1576 integer iy,im,id,ih1577 1578 real plev_min1579 1580 print*,'nlev_astex',nlev_astex1581 plev_min = 55000. ! pas de tendance de vap. d eau au-dessus de 55 hPa1582 1583 open(21,file=trim(fich_astex),form='formatted')1584 read(21,'(a)')1585 read(21,'(a)')1586 do ip = 1, nt_astex1587 read(21,'(a)')1588 read(21,'(a)')1589 read(21,223) iy, im, id, ih, div_astex(ip),ts_astex(ip), &1590 &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vfa_astex(ip)1591 ts_astex(ip)=ts_astex(ip)+273.151592 print *,'ts=',iy,im,id,ih,ip,div_astex(ip),ts_astex(ip), &1593 &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vg_astex(ip)1594 enddo1595 close(21)1596 1597 223 format(4i3,e13.2,f7.2,f7.3,f7.2,f7.3,f7.2)1598 1599 return1600 end1601 !=====================================================================1602 subroutine read_twpice(fich_twpice,nlevel,ntime &1603 & ,T_srf,plev,T,q,u,v,omega &1604 & ,T_adv_h,T_adv_v,q_adv_h,q_adv_v)1605 1606 !program reading forcings of the TWP-ICE experiment1607 1608 ! use netcdf1609 1610 implicit none1611 1612 #include "netcdf.inc"1613 1614 integer ntime,nlevel1615 integer l,k1616 character*80 :: fich_twpice1617 real*8 time(ntime)1618 real*8 lat, lon, alt, phis1619 real*8 lev(nlevel)1620 real*8 plev(nlevel,ntime)1621 1622 real*8 T(nlevel,ntime)1623 real*8 q(nlevel,ntime),u(nlevel,ntime)1624 real*8 v(nlevel,ntime)1625 real*8 omega(nlevel,ntime), div(nlevel,ntime)1626 real*8 T_adv_h(nlevel,ntime)1627 real*8 T_adv_v(nlevel,ntime), q_adv_h(nlevel,ntime)1628 real*8 q_adv_v(nlevel,ntime)1629 real*8 s(nlevel,ntime), s_adv_h(nlevel,ntime)1630 real*8 s_adv_v(nlevel,ntime)1631 real*8 p_srf_aver(ntime), p_srf_center(ntime)1632 real*8 T_srf(ntime)1633 1634 integer nid, ierr1635 integer nbvar3d1636 parameter(nbvar3d=20)1637 integer var3didin(nbvar3d)1638 1639 ierr = NF_OPEN(fich_twpice,NF_NOWRITE,nid)1640 if (ierr.NE.NF_NOERR) then1641 write(*,*) 'ERROR: Pb opening forcings cdf file '1642 write(*,*) NF_STRERROR(ierr)1643 stop ""1644 endif1645 1646 ierr=NF_INQ_VARID(nid,"lat",var3didin(1))1647 if(ierr/=NF_NOERR) then1648 write(*,*) NF_STRERROR(ierr)1649 stop 'lat'1650 endif1651 1652 ierr=NF_INQ_VARID(nid,"lon",var3didin(2))1653 if(ierr/=NF_NOERR) then1654 write(*,*) NF_STRERROR(ierr)1655 stop 'lon'1656 endif1657 1658 ierr=NF_INQ_VARID(nid,"alt",var3didin(3))1659 if(ierr/=NF_NOERR) then1660 write(*,*) NF_STRERROR(ierr)1661 stop 'alt'1662 endif1663 1664 ierr=NF_INQ_VARID(nid,"phis",var3didin(4))1665 if(ierr/=NF_NOERR) then1666 write(*,*) NF_STRERROR(ierr)1667 stop 'phis'1668 endif1669 1670 ierr=NF_INQ_VARID(nid,"T",var3didin(5))1671 if(ierr/=NF_NOERR) then1672 write(*,*) NF_STRERROR(ierr)1673 stop 'T'1674 endif1675 1676 ierr=NF_INQ_VARID(nid,"q",var3didin(6))1677 if(ierr/=NF_NOERR) then1678 write(*,*) NF_STRERROR(ierr)1679 stop 'q'1680 endif1681 1682 ierr=NF_INQ_VARID(nid,"u",var3didin(7))1683 if(ierr/=NF_NOERR) then1684 write(*,*) NF_STRERROR(ierr)1685 stop 'u'1686 endif1687 1688 ierr=NF_INQ_VARID(nid,"v",var3didin(8))1689 if(ierr/=NF_NOERR) then1690 write(*,*) NF_STRERROR(ierr)1691 stop 'v'1692 endif1693 1694 ierr=NF_INQ_VARID(nid,"omega",var3didin(9))1695 if(ierr/=NF_NOERR) then1696 write(*,*) NF_STRERROR(ierr)1697 stop 'omega'1698 endif1699 1700 ierr=NF_INQ_VARID(nid,"div",var3didin(10))1701 if(ierr/=NF_NOERR) then1702 write(*,*) NF_STRERROR(ierr)1703 stop 'div'1704 endif1705 1706 ierr=NF_INQ_VARID(nid,"T_adv_h",var3didin(11))1707 if(ierr/=NF_NOERR) then1708 write(*,*) NF_STRERROR(ierr)1709 stop 'T_adv_h'1710 endif1711 1712 ierr=NF_INQ_VARID(nid,"T_adv_v",var3didin(12))1713 if(ierr/=NF_NOERR) then1714 write(*,*) NF_STRERROR(ierr)1715 stop 'T_adv_v'1716 endif1717 1718 ierr=NF_INQ_VARID(nid,"q_adv_h",var3didin(13))1719 if(ierr/=NF_NOERR) then1720 write(*,*) NF_STRERROR(ierr)1721 stop 'q_adv_h'1722 endif1723 1724 ierr=NF_INQ_VARID(nid,"q_adv_v",var3didin(14))1725 if(ierr/=NF_NOERR) then1726 write(*,*) NF_STRERROR(ierr)1727 stop 'q_adv_v'1728 endif1729 1730 ierr=NF_INQ_VARID(nid,"s",var3didin(15))1731 if(ierr/=NF_NOERR) then1732 write(*,*) NF_STRERROR(ierr)1733 stop 's'1734 endif1735 1736 ierr=NF_INQ_VARID(nid,"s_adv_h",var3didin(16))1737 if(ierr/=NF_NOERR) then1738 write(*,*) NF_STRERROR(ierr)1739 stop 's_adv_h'1740 endif1741 1742 ierr=NF_INQ_VARID(nid,"s_adv_v",var3didin(17))1743 if(ierr/=NF_NOERR) then1744 write(*,*) NF_STRERROR(ierr)1745 stop 's_adv_v'1746 endif1747 1748 ierr=NF_INQ_VARID(nid,"p_srf_aver",var3didin(18))1749 if(ierr/=NF_NOERR) then1750 write(*,*) NF_STRERROR(ierr)1751 stop 'p_srf_aver'1752 endif1753 1754 ierr=NF_INQ_VARID(nid,"p_srf_center",var3didin(19))1755 if(ierr/=NF_NOERR) then1756 write(*,*) NF_STRERROR(ierr)1757 stop 'p_srf_center'1758 endif1759 1760 ierr=NF_INQ_VARID(nid,"T_srf",var3didin(20))1761 if(ierr/=NF_NOERR) then1762 write(*,*) NF_STRERROR(ierr)1763 stop 'T_srf'1764 endif1765 1766 !dimensions lecture1767 call catchaxis(nid,ntime,nlevel,time,lev,ierr)1768 1769 !pressure1770 do l=1,ntime1771 do k=1,nlevel1772 plev(k,l)=lev(k)1773 enddo1774 enddo1775 1776 #ifdef NC_DOUBLE1777 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),lat)1778 #else1779 ierr = NF_GET_VAR_REAL(nid,var3didin(1),lat)1780 #endif1781 if(ierr/=NF_NOERR) then1782 write(*,*) NF_STRERROR(ierr)1783 stop "getvarup"1784 endif1785 ! write(*,*)'lecture lat ok',lat1786 1787 #ifdef NC_DOUBLE1788 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),lon)1789 #else1790 ierr = NF_GET_VAR_REAL(nid,var3didin(2),lon)1791 #endif1792 if(ierr/=NF_NOERR) then1793 write(*,*) NF_STRERROR(ierr)1794 stop "getvarup"1795 endif1796 ! write(*,*)'lecture lon ok',lon1797 1798 #ifdef NC_DOUBLE1799 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),alt)1800 #else1801 ierr = NF_GET_VAR_REAL(nid,var3didin(3),alt)1802 #endif1803 if(ierr/=NF_NOERR) then1804 write(*,*) NF_STRERROR(ierr)1805 stop "getvarup"1806 endif1807 ! write(*,*)'lecture alt ok',alt1808 1809 #ifdef NC_DOUBLE1810 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),phis)1811 #else1812 ierr = NF_GET_VAR_REAL(nid,var3didin(4),phis)1813 #endif1814 if(ierr/=NF_NOERR) then1815 write(*,*) NF_STRERROR(ierr)1816 stop "getvarup"1817 endif1818 ! write(*,*)'lecture phis ok',phis1819 1820 #ifdef NC_DOUBLE1821 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),T)1822 #else1823 ierr = NF_GET_VAR_REAL(nid,var3didin(5),T)1824 #endif1825 if(ierr/=NF_NOERR) then1826 write(*,*) NF_STRERROR(ierr)1827 stop "getvarup"1828 endif1829 ! write(*,*)'lecture T ok'1830 1831 #ifdef NC_DOUBLE1832 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),q)1833 #else1834 ierr = NF_GET_VAR_REAL(nid,var3didin(6),q)1835 #endif1836 if(ierr/=NF_NOERR) then1837 write(*,*) NF_STRERROR(ierr)1838 stop "getvarup"1839 endif1840 ! write(*,*)'lecture q ok'1841 !q in kg/kg1842 do l=1,ntime1843 do k=1,nlevel1844 q(k,l)=q(k,l)/1000.1845 enddo1846 enddo1847 #ifdef NC_DOUBLE1848 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),u)1849 #else1850 ierr = NF_GET_VAR_REAL(nid,var3didin(7),u)1851 #endif1852 if(ierr/=NF_NOERR) then1853 write(*,*) NF_STRERROR(ierr)1854 stop "getvarup"1855 endif1856 ! write(*,*)'lecture u ok'1857 1858 #ifdef NC_DOUBLE1859 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),v)1860 #else1861 ierr = NF_GET_VAR_REAL(nid,var3didin(8),v)1862 #endif1863 if(ierr/=NF_NOERR) then1864 write(*,*) NF_STRERROR(ierr)1865 stop "getvarup"1866 endif1867 ! write(*,*)'lecture v ok'1868 1869 #ifdef NC_DOUBLE1870 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),omega)1871 #else1872 ierr = NF_GET_VAR_REAL(nid,var3didin(9),omega)1873 #endif1874 if(ierr/=NF_NOERR) then1875 write(*,*) NF_STRERROR(ierr)1876 stop "getvarup"1877 endif1878 ! write(*,*)'lecture omega ok'1879 !omega in mb/hour1880 do l=1,ntime1881 do k=1,nlevel1882 omega(k,l)=omega(k,l)*100./3600.1883 enddo1884 enddo1885 1886 #ifdef NC_DOUBLE1887 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),div)1888 #else1889 ierr = NF_GET_VAR_REAL(nid,var3didin(10),div)1890 #endif1891 if(ierr/=NF_NOERR) then1892 write(*,*) NF_STRERROR(ierr)1893 stop "getvarup"1894 endif1895 ! write(*,*)'lecture div ok'1896 1897 #ifdef NC_DOUBLE1898 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),T_adv_h)1899 #else1900 ierr = NF_GET_VAR_REAL(nid,var3didin(11),T_adv_h)1901 #endif1902 if(ierr/=NF_NOERR) then1903 write(*,*) NF_STRERROR(ierr)1904 stop "getvarup"1905 endif1906 ! write(*,*)'lecture T_adv_h ok'1907 !T adv in K/s1908 do l=1,ntime1909 do k=1,nlevel1910 T_adv_h(k,l)=T_adv_h(k,l)/3600.1911 enddo1912 enddo1913 1914 1915 #ifdef NC_DOUBLE1916 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),T_adv_v)1917 #else1918 ierr = NF_GET_VAR_REAL(nid,var3didin(12),T_adv_v)1919 #endif1920 if(ierr/=NF_NOERR) then1921 write(*,*) NF_STRERROR(ierr)1922 stop "getvarup"1923 endif1924 ! write(*,*)'lecture T_adv_v ok'1925 !T adv in K/s1926 do l=1,ntime1927 do k=1,nlevel1928 T_adv_v(k,l)=T_adv_v(k,l)/3600.1929 enddo1930 enddo1931 1932 #ifdef NC_DOUBLE1933 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),q_adv_h)1934 #else1935 ierr = NF_GET_VAR_REAL(nid,var3didin(13),q_adv_h)1936 #endif1937 if(ierr/=NF_NOERR) then1938 write(*,*) NF_STRERROR(ierr)1939 stop "getvarup"1940 endif1941 ! write(*,*)'lecture q_adv_h ok'1942 !q adv in kg/kg/s1943 do l=1,ntime1944 do k=1,nlevel1945 q_adv_h(k,l)=q_adv_h(k,l)/1000./3600.1946 enddo1947 enddo1948 1949 1950 #ifdef NC_DOUBLE1951 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),q_adv_v)1952 #else1953 ierr = NF_GET_VAR_REAL(nid,var3didin(14),q_adv_v)1954 #endif1955 if(ierr/=NF_NOERR) then1956 write(*,*) NF_STRERROR(ierr)1957 stop "getvarup"1958 endif1959 ! write(*,*)'lecture q_adv_v ok'1960 !q adv in kg/kg/s1961 do l=1,ntime1962 do k=1,nlevel1963 q_adv_v(k,l)=q_adv_v(k,l)/1000./3600.1964 enddo1965 enddo1966 1967 1968 #ifdef NC_DOUBLE1969 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),s)1970 #else1971 ierr = NF_GET_VAR_REAL(nid,var3didin(15),s)1972 #endif1973 if(ierr/=NF_NOERR) then1974 write(*,*) NF_STRERROR(ierr)1975 stop "getvarup"1976 endif1977 1978 #ifdef NC_DOUBLE1979 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),s_adv_h)1980 #else1981 ierr = NF_GET_VAR_REAL(nid,var3didin(16),s_adv_h)1982 #endif1983 if(ierr/=NF_NOERR) then1984 write(*,*) NF_STRERROR(ierr)1985 stop "getvarup"1986 endif1987 1988 #ifdef NC_DOUBLE1989 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),s_adv_v)1990 #else1991 ierr = NF_GET_VAR_REAL(nid,var3didin(17),s_adv_v)1992 #endif1993 if(ierr/=NF_NOERR) then1994 write(*,*) NF_STRERROR(ierr)1995 stop "getvarup"1996 endif1997 1998 #ifdef NC_DOUBLE1999 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),p_srf_aver)2000 #else2001 ierr = NF_GET_VAR_REAL(nid,var3didin(18),p_srf_aver)2002 #endif2003 if(ierr/=NF_NOERR) then2004 write(*,*) NF_STRERROR(ierr)2005 stop "getvarup"2006 endif2007 2008 #ifdef NC_DOUBLE2009 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),p_srf_center)2010 #else2011 ierr = NF_GET_VAR_REAL(nid,var3didin(19),p_srf_center)2012 #endif2013 if(ierr/=NF_NOERR) then2014 write(*,*) NF_STRERROR(ierr)2015 stop "getvarup"2016 endif2017 2018 #ifdef NC_DOUBLE2019 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),T_srf)2020 #else2021 ierr = NF_GET_VAR_REAL(nid,var3didin(20),T_srf)2022 #endif2023 if(ierr/=NF_NOERR) then2024 write(*,*) NF_STRERROR(ierr)2025 stop "getvarup"2026 endif2027 ! write(*,*)'lecture T_srf ok', T_srf2028 2029 return2030 end subroutine read_twpice2031 !=====================================================================2032 subroutine catchaxis(nid,ttm,llm,time,lev,ierr)2033 2034 ! use netcdf2035 2036 implicit none2037 #include "netcdf.inc"2038 integer nid,ttm,llm2039 real*8 time(ttm)2040 real*8 lev(llm)2041 integer ierr2042 2043 integer timevar,levvar2044 integer timelen,levlen2045 integer timedimin,levdimin2046 2047 ! Control & lecture on dimensions2048 ! ===============================2049 ierr=NF_INQ_DIMID(nid,"time",timedimin)2050 ierr=NF_INQ_VARID(nid,"time",timevar)2051 if (ierr.NE.NF_NOERR) then2052 write(*,*) 'ERROR: Field <time> is missing'2053 stop ""2054 endif2055 ierr=NF_INQ_DIMLEN(nid,timedimin,timelen)2056 2057 ierr=NF_INQ_DIMID(nid,"lev",levdimin)2058 ierr=NF_INQ_VARID(nid,"lev",levvar)2059 if (ierr.NE.NF_NOERR) then2060 write(*,*) 'ERROR: Field <lev> is lacking'2061 stop ""2062 endif2063 ierr=NF_INQ_DIMLEN(nid,levdimin,levlen)2064 2065 if((timelen/=ttm).or.(levlen/=llm)) then2066 write(*,*) 'ERROR: Not the good lenght for axis'2067 write(*,*) 'longitude: ',timelen,ttm+12068 write(*,*) 'latitude: ',levlen,llm2069 stop ""2070 endif2071 2072 !#ifdef NC_DOUBLE2073 ierr = NF_GET_VAR_DOUBLE(nid,timevar,time)2074 ierr = NF_GET_VAR_DOUBLE(nid,levvar,lev)2075 !#else2076 ! ierr = NF_GET_VAR_REAL(nid,timevar,time)2077 ! ierr = NF_GET_VAR_REAL(nid,levvar,lev)2078 !#endif2079 2080 return2081 end2082 !=====================================================================2083 2084 SUBROUTINE interp_sandu_vertical(play,nlev_sandu,plev_prof &2085 & ,t_prof,thl_prof,q_prof,u_prof,v_prof,w_prof &2086 & ,omega_prof,o3mmr_prof &2087 & ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod &2088 & ,omega_mod,o3mmr_mod,mxcalc)2089 2090 implicit none2091 2092 #include "dimensions.h"2093 2094 !-------------------------------------------------------------------------2095 ! Vertical interpolation of SANDUREF forcing data onto model levels2096 !-------------------------------------------------------------------------2097 2098 integer nlevmax2099 parameter (nlevmax=41)2100 integer nlev_sandu,mxcalc2101 ! real play(llm), plev_prof(nlevmax)2102 ! real t_prof(nlevmax),q_prof(nlevmax)2103 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2104 ! real ht_prof(nlevmax),vt_prof(nlevmax)2105 ! real hq_prof(nlevmax),vq_prof(nlevmax)2106 2107 real play(llm), plev_prof(nlev_sandu)2108 real t_prof(nlev_sandu),thl_prof(nlev_sandu),q_prof(nlev_sandu)2109 real u_prof(nlev_sandu),v_prof(nlev_sandu), w_prof(nlev_sandu)2110 real omega_prof(nlev_sandu),o3mmr_prof(nlev_sandu)2111 2112 real t_mod(llm),thl_mod(llm),q_mod(llm)2113 real u_mod(llm),v_mod(llm), w_mod(llm)2114 real omega_mod(llm),o3mmr_mod(llm)2115 2116 integer l,k,k1,k22117 real frac,frac1,frac2,fact2118 2119 do l = 1, llm2120 2121 if (play(l).ge.plev_prof(nlev_sandu)) then2122 2123 mxcalc=l2124 k1=02125 k2=02126 2127 if (play(l).le.plev_prof(1)) then2128 2129 do k = 1, nlev_sandu-12130 if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then2131 k1=k2132 k2=k+12133 endif2134 enddo2135 2136 if (k1.eq.0 .or. k2.eq.0) then2137 write(*,*) 'PB! k1, k2 = ',k1,k22138 write(*,*) 'l,play(l) = ',l,play(l)/1002139 do k = 1, nlev_sandu-12140 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002141 enddo2142 endif2143 2144 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2145 t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))2146 thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))2147 q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))2148 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2149 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2150 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2151 omega_mod(l)=omega_prof(k2)-frac*(omega_prof(k2)-omega_prof(k1))2152 o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))2153 2154 else !play>plev_prof(1)2155 2156 k1=12157 k2=22158 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2159 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2160 t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)2161 thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)2162 q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)2163 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2164 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2165 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2166 omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)2167 o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)2168 2169 endif ! play.le.plev_prof(1)2170 2171 else ! above max altitude of forcing file2172 2173 !jyg2174 fact=20.*(plev_prof(nlev_sandu)-play(l))/plev_prof(nlev_sandu) !jyg2175 fact = max(fact,0.) !jyg2176 fact = exp(-fact) !jyg2177 t_mod(l)= t_prof(nlev_sandu) !jyg2178 thl_mod(l)= thl_prof(nlev_sandu) !jyg2179 q_mod(l)= q_prof(nlev_sandu)*fact !jyg2180 u_mod(l)= u_prof(nlev_sandu)*fact !jyg2181 v_mod(l)= v_prof(nlev_sandu)*fact !jyg2182 w_mod(l)= w_prof(nlev_sandu)*fact !jyg2183 omega_mod(l)= omega_prof(nlev_sandu)*fact !jyg2184 o3mmr_mod(l)= o3mmr_prof(nlev_sandu)*fact !jyg2185 2186 endif ! play2187 2188 enddo ! l2189 2190 do l = 1,llm2191 ! print *,'t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l) ',2192 ! $ l,t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l)2193 enddo2194 2195 return2196 end2197 !=====================================================================2198 SUBROUTINE interp_astex_vertical(play,nlev_astex,plev_prof &2199 & ,t_prof,thl_prof,qv_prof,ql_prof,qt_prof,u_prof,v_prof &2200 & ,w_prof,tke_prof,o3mmr_prof &2201 & ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod &2202 & ,tke_mod,o3mmr_mod,mxcalc)2203 2204 implicit none2205 2206 #include "dimensions.h"2207 2208 !-------------------------------------------------------------------------2209 ! Vertical interpolation of Astex forcing data onto model levels2210 !-------------------------------------------------------------------------2211 2212 integer nlevmax2213 parameter (nlevmax=41)2214 integer nlev_astex,mxcalc2215 ! real play(llm), plev_prof(nlevmax)2216 ! real t_prof(nlevmax),qv_prof(nlevmax)2217 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2218 ! real ht_prof(nlevmax),vt_prof(nlevmax)2219 ! real hq_prof(nlevmax),vq_prof(nlevmax)2220 2221 real play(llm), plev_prof(nlev_astex)2222 real t_prof(nlev_astex),thl_prof(nlev_astex),qv_prof(nlev_astex)2223 real u_prof(nlev_astex),v_prof(nlev_astex), w_prof(nlev_astex)2224 real o3mmr_prof(nlev_astex),ql_prof(nlev_astex)2225 real qt_prof(nlev_astex),tke_prof(nlev_astex)2226 2227 real t_mod(llm),thl_mod(llm),qv_mod(llm)2228 real u_mod(llm),v_mod(llm), w_mod(llm),tke_mod(llm)2229 real o3mmr_mod(llm),ql_mod(llm),qt_mod(llm)2230 2231 integer l,k,k1,k22232 real frac,frac1,frac2,fact2233 2234 do l = 1, llm2235 2236 if (play(l).ge.plev_prof(nlev_astex)) then2237 2238 mxcalc=l2239 k1=02240 k2=02241 2242 if (play(l).le.plev_prof(1)) then2243 2244 do k = 1, nlev_astex-12245 if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then2246 k1=k2247 k2=k+12248 endif2249 enddo2250 2251 if (k1.eq.0 .or. k2.eq.0) then2252 write(*,*) 'PB! k1, k2 = ',k1,k22253 write(*,*) 'l,play(l) = ',l,play(l)/1002254 do k = 1, nlev_astex-12255 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002256 enddo2257 endif2258 2259 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2260 t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))2261 thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))2262 qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))2263 ql_mod(l)= ql_prof(k2) - frac*(ql_prof(k2)-ql_prof(k1))2264 qt_mod(l)= qt_prof(k2) - frac*(qt_prof(k2)-qt_prof(k1))2265 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2266 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2267 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2268 tke_mod(l)= tke_prof(k2) - frac*(tke_prof(k2)-tke_prof(k1))2269 o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))2270 2271 else !play>plev_prof(1)2272 2273 k1=12274 k2=22275 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2276 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2277 t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)2278 thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)2279 qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)2280 ql_mod(l)= frac1*ql_prof(k1) - frac2*ql_prof(k2)2281 qt_mod(l)= frac1*qt_prof(k1) - frac2*qt_prof(k2)2282 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2283 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2284 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2285 tke_mod(l)= frac1*tke_prof(k1) - frac2*tke_prof(k2)2286 o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)2287 2288 endif ! play.le.plev_prof(1)2289 2290 else ! above max altitude of forcing file2291 2292 !jyg2293 fact=20.*(plev_prof(nlev_astex)-play(l))/plev_prof(nlev_astex) !jyg2294 fact = max(fact,0.) !jyg2295 fact = exp(-fact) !jyg2296 t_mod(l)= t_prof(nlev_astex) !jyg2297 thl_mod(l)= thl_prof(nlev_astex) !jyg2298 qv_mod(l)= qv_prof(nlev_astex)*fact !jyg2299 ql_mod(l)= ql_prof(nlev_astex)*fact !jyg2300 qt_mod(l)= qt_prof(nlev_astex)*fact !jyg2301 u_mod(l)= u_prof(nlev_astex)*fact !jyg2302 v_mod(l)= v_prof(nlev_astex)*fact !jyg2303 w_mod(l)= w_prof(nlev_astex)*fact !jyg2304 tke_mod(l)= tke_prof(nlev_astex)*fact !jyg2305 o3mmr_mod(l)= o3mmr_prof(nlev_astex)*fact !jyg2306 2307 endif ! play2308 2309 enddo ! l2310 2311 do l = 1,llm2312 ! print *,'t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l) ',2313 ! $ l,t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l)2314 enddo2315 2316 return2317 end2318 2319 !======================================================================2320 SUBROUTINE read_rico(fich_rico,nlev_rico,ps_rico,play &2321 & ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico &2322 & ,dth_dyn,dqh_dyn)2323 implicit none2324 2325 !-------------------------------------------------------------------------2326 ! Read RICO forcing data2327 !-------------------------------------------------------------------------2328 #include "dimensions.h"2329 2330 2331 integer nlev_rico2332 real ts_rico,ps_rico2333 real t_rico(llm),q_rico(llm)2334 real u_rico(llm),v_rico(llm)2335 real w_rico(llm)2336 real dth_dyn(llm)2337 real dqh_dyn(llm)2338 2339 2340 real play(llm),zlay(llm)2341 2342 2343 real prico(nlev_rico),zrico(nlev_rico)2344 2345 character*80 fich_rico2346 2347 integer k,l2348 2349 2350 print*,fich_rico2351 open(21,file=trim(fich_rico),form='formatted')2352 do k=1,llm2353 zlay(k)=0.2354 enddo2355 2356 read(21,*) ps_rico,ts_rico2357 prico(1)=ps_rico2358 zrico(1)=0.02359 do l=2,nlev_rico2360 read(21,*) k,prico(l),zrico(l)2361 enddo2362 close(21)2363 2364 do k=1,llm2365 do l=1,802366 if(prico(l)>play(k)) then2367 if(play(k)>prico(l+1)) then2368 zlay(k)=zrico(l)+(play(k)-prico(l)) * &2369 & (zrico(l+1)-zrico(l))/(prico(l+1)-prico(l))2370 else2371 zlay(k)=zrico(l)+(play(k)-prico(80))* &2372 & (zrico(81)-zrico(80))/(prico(81)-prico(80))2373 endif2374 endif2375 enddo2376 print*,k,zlay(k)2377 ! U2378 if(0 < zlay(k) .and. zlay(k) < 4000) then2379 u_rico(k)=-9.9 + (-1.9 + 9.9)*zlay(k)/40002380 elseif(4000 < zlay(k) .and. zlay(k) < 12000) then2381 u_rico(k)= -1.9 + (30.0 + 1.9) / &2382 & (12000 - 4000) * (zlay(k) - 4000)2383 elseif(12000 < zlay(k) .and. zlay(k) < 13000) then2384 u_rico(k)=30.02385 elseif(13000 < zlay(k) .and. zlay(k) < 20000) then2386 u_rico(k)=30.0 - (30.0) / &2387 & (20000 - 13000) * (zlay(k) - 13000)2388 else2389 u_rico(k)=0.02390 endif2391 2392 !Q_v2393 if(0 < zlay(k) .and. zlay(k) < 740) then2394 q_rico(k)=16.0 + (13.8 - 16.0) / (740) * zlay(k)2395 elseif(740 < zlay(k) .and. zlay(k) < 3260) then2396 q_rico(k)=13.8 + (2.4 - 13.8) / &2397 & (3260 - 740) * (zlay(k) - 740)2398 elseif(3260 < zlay(k) .and. zlay(k) < 4000) then2399 q_rico(k)=2.4 + (1.8 - 2.4) / &2400 & (4000 - 3260) * (zlay(k) - 3260)2401 elseif(4000 < zlay(k) .and. zlay(k) < 9000) then2402 q_rico(k)=1.8 + (0 - 1.8) / &2403 & (9000 - 4000) * (zlay(k) - 4000)2404 else2405 q_rico(k)=0.02406 endif2407 2408 !T2409 if(0 < zlay(k) .and. zlay(k) < 740) then2410 t_rico(k)=299.2 + (292.0 - 299.2) / (740) * zlay(k)2411 elseif(740 < zlay(k) .and. zlay(k) < 4000) then2412 t_rico(k)=292.0 + (278.0 - 292.0) / &2413 & (4000 - 740) * (zlay(k) - 740)2414 elseif(4000 < zlay(k) .and. zlay(k) < 15000) then2415 t_rico(k)=278.0 + (203.0 - 278.0) / &2416 & (15000 - 4000) * (zlay(k) - 4000)2417 elseif(15000 < zlay(k) .and. zlay(k) < 17500) then2418 t_rico(k)=203.0 + (194.0 - 203.0) / &2419 & (17500 - 15000)* (zlay(k) - 15000)2420 elseif(17500 < zlay(k) .and. zlay(k) < 20000) then2421 t_rico(k)=194.0 + (206.0 - 194.0) / &2422 & (20000 - 17500)* (zlay(k) - 17500)2423 elseif(20000 < zlay(k) .and. zlay(k) < 60000) then2424 t_rico(k)=206.0 + (270.0 - 206.0) / &2425 & (60000 - 20000)* (zlay(k) - 20000)2426 endif2427 2428 ! W2429 if(0 < zlay(k) .and. zlay(k) < 2260 ) then2430 w_rico(k)=- (0.005/2260) * zlay(k)2431 elseif(2260 < zlay(k) .and. zlay(k) < 4000 ) then2432 w_rico(k)=- 0.0052433 elseif(4000 < zlay(k) .and. zlay(k) < 5000 ) then2434 w_rico(k)=- 0.005 + (0.005/ (5000 - 4000)) * (zlay(k) - 4000)2435 else2436 w_rico(k)=0.02437 endif2438 2439 ! dThrz+dTsw0+dTlw02440 if(0 < zlay(k) .and. zlay(k) < 4000) then2441 dth_dyn(k)=- 2.51 / 86400 + (-2.18 + 2.51 )/ &2442 & (86400*4000) * zlay(k)2443 elseif(4000 < zlay(k) .and. zlay(k) < 5000) then2444 dth_dyn(k)=- 2.18 / 86400 + ( 2.18 ) / &2445 & (86400*(5000 - 4000)) * (zlay(k) - 4000)2446 else2447 dth_dyn(k)=0.02448 endif2449 ! dQhrz2450 if(0 < zlay(k) .and. zlay(k) < 3000) then2451 dqh_dyn(k)=-1.0 / 86400 + (0.345 + 1.0)/ &2452 & (86400*3000) * (zlay(k))2453 elseif(3000 < zlay(k) .and. zlay(k) < 4000) then2454 dqh_dyn(k)=0.345 / 864002455 elseif(4000 < zlay(k) .and. zlay(k) < 5000) then2456 dqh_dyn(k)=0.345 / 86400 + &2457 & (-0.345)/(86400 * (5000 - 4000)) * (zlay(k)-4000)2458 else2459 dqh_dyn(k)=0.02460 endif2461 2462 !? if(play(k)>6e4) then2463 !? ratqs0(1,k)=ratqsbas*(plev(1)-play(k))/(plev(1)-6e4)2464 !? elseif((play(k)>3e4).and.(play(k)<6e4)) then2465 !? ratqs0(1,k)=ratqsbas+(ratqshaut-ratqsbas)&2466 !? *(6e4-play(k))/(6e4-3e4)2467 !? else2468 !? ratqs0(1,k)=ratqshaut2469 !? endif2470 2471 enddo2472 2473 do k=1,llm2474 q_rico(k)=q_rico(k)/1e32475 dqh_dyn(k)=dqh_dyn(k)/1e32476 v_rico(k)=-3.82477 enddo2478 2479 return2480 end2481 2482 !======================================================================2483 SUBROUTINE interp_sandu_time(day,day1,annee_ref &2484 & ,year_ini_sandu,day_ini_sandu,nt_sandu,dt_sandu &2485 & ,nlev_sandu,ts_sandu,ts_prof)2486 implicit none2487 2488 !---------------------------------------------------------------------------------------2489 ! Time interpolation of a 2D field to the timestep corresponding to day2490 !2491 ! day: current julian day (e.g. 717538.2)2492 ! day1: first day of the simulation2493 ! nt_sandu: total nb of data in the forcing (e.g. 13 for Sanduref)2494 ! dt_sandu: total time interval (in sec) between 2 forcing data (e.g. 6h for Sanduref)2495 !---------------------------------------------------------------------------------------2496 ! inputs:2497 integer annee_ref2498 integer nt_sandu,nlev_sandu2499 integer year_ini_sandu2500 real day, day1,day_ini_sandu,dt_sandu2501 real ts_sandu(nt_sandu)2502 ! outputs:2503 real ts_prof2504 ! local:2505 integer it_sandu1, it_sandu22506 real timeit,time_sandu1,time_sandu2,frac2507 ! Check that initial day of the simulation consistent with SANDU period:2508 if (annee_ref.ne.2006 ) then2509 print*,'Pour SANDUREF, annee_ref doit etre 2006 '2510 print*,'Changer annee_ref dans run.def'2511 stop2512 endif2513 ! if (annee_ref.eq.2006 .and. day1.lt.day_ini_sandu) then2514 ! print*,'SANDUREF debute le 15 Juillet 2006 (jour julien=196)'2515 ! print*,'Changer dayref dans run.def'2516 ! stop2517 ! endif2518 2519 ! Determine timestep relative to the 1st day of TOGA-COARE:2520 ! timeit=(day-day1)*86400.2521 ! if (annee_ref.eq.1992) then2522 ! timeit=(day-day_ini_sandu)*86400.2523 ! else2524 ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 19922525 ! endif2526 timeit=(day-day_ini_sandu)*864002527 2528 ! Determine the closest observation times:2529 it_sandu1=INT(timeit/dt_sandu)+12530 it_sandu2=it_sandu1 + 12531 time_sandu1=(it_sandu1-1)*dt_sandu2532 time_sandu2=(it_sandu2-1)*dt_sandu2533 print *,'timeit day day_ini_sandu',timeit,day,day_ini_sandu2534 print *,'it_sandu1,it_sandu2,time_sandu1,time_sandu2', &2535 & it_sandu1,it_sandu2,time_sandu1,time_sandu22536 2537 if (it_sandu1 .ge. nt_sandu) then2538 write(*,*) 'PB-stop: day, it_sandu1, it_sandu2, timeit: ' &2539 & ,day,it_sandu1,it_sandu2,timeit/86400.2540 stop2541 endif2542 2543 ! time interpolation:2544 frac=(time_sandu2-timeit)/(time_sandu2-time_sandu1)2545 frac=max(frac,0.0)2546 2547 ts_prof = ts_sandu(it_sandu2) &2548 & -frac*(ts_sandu(it_sandu2)-ts_sandu(it_sandu1))2549 2550 print*, &2551 &'day,annee_ref,day_ini_sandu,timeit,it_sandu1,it_sandu2,SST:', &2552 &day,annee_ref,day_ini_sandu,timeit/86400.,it_sandu1, &2553 &it_sandu2,ts_prof2554 2555 return2556 END2557 !=====================================================================2558 !-------------------------------------------------------------------------2559 SUBROUTINE read_armcu(fich_armcu,nlev_armcu,nt_armcu, &2560 & sens,flat,adv_theta,rad_theta,adv_qt)2561 implicit none2562 2563 !-------------------------------------------------------------------------2564 ! Read ARM_CU case forcing data2565 !-------------------------------------------------------------------------2566 2567 integer nlev_armcu,nt_armcu2568 real sens(nt_armcu),flat(nt_armcu)2569 real adv_theta(nt_armcu),rad_theta(nt_armcu),adv_qt(nt_armcu)2570 character*80 fich_armcu2571 2572 integer ip2573 2574 integer iy,im,id,ih,in2575 2576 print*,'nlev_armcu',nlev_armcu2577 2578 open(21,file=trim(fich_armcu),form='formatted')2579 read(21,'(a)')2580 do ip = 1, nt_armcu2581 read(21,'(a)')2582 read(21,'(a)')2583 read(21,223) iy, im, id, ih, in, sens(ip),flat(ip), &2584 & adv_theta(ip),rad_theta(ip),adv_qt(ip)2585 print *,'forcages=',iy,im,id,ih,in, sens(ip),flat(ip), &2586 & adv_theta(ip),rad_theta(ip),adv_qt(ip)2587 enddo2588 close(21)2589 2590 223 format(5i3,5f8.3)2591 2592 return2593 end2594 2595 !=====================================================================2596 SUBROUTINE interp_toga_vertical(play,nlev_toga,plev_prof &2597 & ,t_prof,q_prof,u_prof,v_prof,w_prof &2598 & ,ht_prof,vt_prof,hq_prof,vq_prof &2599 & ,t_mod,q_mod,u_mod,v_mod,w_mod &2600 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)2601 2602 implicit none2603 2604 #include "dimensions.h"2605 2606 !-------------------------------------------------------------------------2607 ! Vertical interpolation of TOGA-COARE forcing data onto model levels2608 !-------------------------------------------------------------------------2609 2610 integer nlevmax2611 parameter (nlevmax=41)2612 integer nlev_toga,mxcalc2613 ! real play(llm), plev_prof(nlevmax)2614 ! real t_prof(nlevmax),q_prof(nlevmax)2615 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2616 ! real ht_prof(nlevmax),vt_prof(nlevmax)2617 ! real hq_prof(nlevmax),vq_prof(nlevmax)2618 2619 real play(llm), plev_prof(nlev_toga)2620 real t_prof(nlev_toga),q_prof(nlev_toga)2621 real u_prof(nlev_toga),v_prof(nlev_toga), w_prof(nlev_toga)2622 real ht_prof(nlev_toga),vt_prof(nlev_toga)2623 real hq_prof(nlev_toga),vq_prof(nlev_toga)2624 2625 real t_mod(llm),q_mod(llm)2626 real u_mod(llm),v_mod(llm), w_mod(llm)2627 real ht_mod(llm),vt_mod(llm)2628 real hq_mod(llm),vq_mod(llm)2629 2630 integer l,k,k1,k22631 real frac,frac1,frac2,fact2632 2633 do l = 1, llm2634 2635 if (play(l).ge.plev_prof(nlev_toga)) then2636 2637 mxcalc=l2638 k1=02639 k2=02640 2641 if (play(l).le.plev_prof(1)) then2642 2643 do k = 1, nlev_toga-12644 if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then2645 k1=k2646 k2=k+12647 endif2648 enddo2649 2650 if (k1.eq.0 .or. k2.eq.0) then2651 write(*,*) 'PB! k1, k2 = ',k1,k22652 write(*,*) 'l,play(l) = ',l,play(l)/1002653 do k = 1, nlev_toga-12654 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002655 enddo2656 endif2657 2658 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2659 t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))2660 q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))2661 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2662 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2663 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2664 ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))2665 vt_mod(l)= vt_prof(k2) - frac*(vt_prof(k2)-vt_prof(k1))2666 hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))2667 vq_mod(l)= vq_prof(k2) - frac*(vq_prof(k2)-vq_prof(k1))2668 2669 else !play>plev_prof(1)2670 2671 k1=12672 k2=22673 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2674 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2675 t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)2676 q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)2677 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2678 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2679 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2680 ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)2681 vt_mod(l)= frac1*vt_prof(k1) - frac2*vt_prof(k2)2682 hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)2683 vq_mod(l)= frac1*vq_prof(k1) - frac2*vq_prof(k2)2684 2685 endif ! play.le.plev_prof(1)2686 2687 else ! above max altitude of forcing file2688 2689 !jyg2690 fact=20.*(plev_prof(nlev_toga)-play(l))/plev_prof(nlev_toga) !jyg2691 fact = max(fact,0.) !jyg2692 fact = exp(-fact) !jyg2693 t_mod(l)= t_prof(nlev_toga) !jyg2694 q_mod(l)= q_prof(nlev_toga)*fact !jyg2695 u_mod(l)= u_prof(nlev_toga)*fact !jyg2696 v_mod(l)= v_prof(nlev_toga)*fact !jyg2697 w_mod(l)= 0.0 !jyg2698 ht_mod(l)= ht_prof(nlev_toga) !jyg2699 vt_mod(l)= vt_prof(nlev_toga) !jyg2700 hq_mod(l)= hq_prof(nlev_toga)*fact !jyg2701 vq_mod(l)= vq_prof(nlev_toga)*fact !jyg2702 2703 endif ! play2704 2705 enddo ! l2706 2707 ! do l = 1,llm2708 ! print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',2709 ! $ l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)2710 ! enddo2711 2712 return2713 end2714 2715 !=====================================================================2716 SUBROUTINE interp_case_vertical(play,nlev_cas,plev_prof_cas &2717 & ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas &2718 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas &2719 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas &2720 & ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas &2721 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas &2722 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc)2723 2724 implicit none2725 2726 #include "dimensions.h"2727 2728 !-------------------------------------------------------------------------2729 ! Vertical interpolation of TOGA-COARE forcing data onto mod_casel levels2730 !-------------------------------------------------------------------------2731 2732 integer nlevmax2733 parameter (nlevmax=41)2734 integer nlev_cas,mxcalc2735 ! real play(llm), plev_prof(nlevmax)2736 ! real t_prof(nlevmax),q_prof(nlevmax)2737 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2738 ! real ht_prof(nlevmax),vt_prof(nlevmax)2739 ! real hq_prof(nlevmax),vq_prof(nlevmax)2740 2741 real play(llm), plev_prof_cas(nlev_cas)2742 real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)2743 real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)2744 real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas)2745 real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)2746 real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)2747 real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas),dtrad_prof_cas(nlev_cas)2748 real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)2749 2750 real t_mod_cas(llm),q_mod_cas(llm)2751 real u_mod_cas(llm),v_mod_cas(llm)2752 real ug_mod_cas(llm),vg_mod_cas(llm), w_mod_cas(llm)2753 real du_mod_cas(llm),hu_mod_cas(llm),vu_mod_cas(llm)2754 real dv_mod_cas(llm),hv_mod_cas(llm),vv_mod_cas(llm)2755 real dt_mod_cas(llm),ht_mod_cas(llm),vt_mod_cas(llm),dtrad_mod_cas(llm)2756 real dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)2757 2758 integer l,k,k1,k22759 real frac,frac1,frac2,fact2760 2761 do l = 1, llm2762 2763 if (play(l).ge.plev_prof_cas(nlev_cas)) then2764 2765 mxcalc=l2766 k1=02767 k2=02768 2769 if (play(l).le.plev_prof_cas(1)) then2770 2771 do k = 1, nlev_cas-12772 if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then2773 k1=k2774 k2=k+12775 endif2776 enddo2777 2778 if (k1.eq.0 .or. k2.eq.0) then2779 write(*,*) 'PB! k1, k2 = ',k1,k22780 write(*,*) 'l,play(l) = ',l,play(l)/1002781 do k = 1, nlev_cas-12782 write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/1002783 enddo2784 endif2785 2786 frac = (plev_prof_cas(k2)-play(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))2787 t_mod_cas(l)= t_prof_cas(k2) - frac*(t_prof_cas(k2)-t_prof_cas(k1))2788 q_mod_cas(l)= q_prof_cas(k2) - frac*(q_prof_cas(k2)-q_prof_cas(k1))2789 u_mod_cas(l)= u_prof_cas(k2) - frac*(u_prof_cas(k2)-u_prof_cas(k1))2790 v_mod_cas(l)= v_prof_cas(k2) - frac*(v_prof_cas(k2)-v_prof_cas(k1))2791 ug_mod_cas(l)= ug_prof_cas(k2) - frac*(ug_prof_cas(k2)-ug_prof_cas(k1))2792 vg_mod_cas(l)= vg_prof_cas(k2) - frac*(vg_prof_cas(k2)-vg_prof_cas(k1))2793 w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_prof_cas(k1))2794 du_mod_cas(l)= du_prof_cas(k2) - frac*(du_prof_cas(k2)-du_prof_cas(k1))2795 hu_mod_cas(l)= hu_prof_cas(k2) - frac*(hu_prof_cas(k2)-hu_prof_cas(k1))2796 vu_mod_cas(l)= vu_prof_cas(k2) - frac*(vu_prof_cas(k2)-vu_prof_cas(k1))2797 dv_mod_cas(l)= dv_prof_cas(k2) - frac*(dv_prof_cas(k2)-dv_prof_cas(k1))2798 hv_mod_cas(l)= hv_prof_cas(k2) - frac*(hv_prof_cas(k2)-hv_prof_cas(k1))2799 vv_mod_cas(l)= vv_prof_cas(k2) - frac*(vv_prof_cas(k2)-vv_prof_cas(k1))2800 dt_mod_cas(l)= dt_prof_cas(k2) - frac*(dt_prof_cas(k2)-dt_prof_cas(k1))2801 ht_mod_cas(l)= ht_prof_cas(k2) - frac*(ht_prof_cas(k2)-ht_prof_cas(k1))2802 vt_mod_cas(l)= vt_prof_cas(k2) - frac*(vt_prof_cas(k2)-vt_prof_cas(k1))2803 dq_mod_cas(l)= dq_prof_cas(k2) - frac*(dq_prof_cas(k2)-dq_prof_cas(k1))2804 hq_mod_cas(l)= hq_prof_cas(k2) - frac*(hq_prof_cas(k2)-hq_prof_cas(k1))2805 vq_mod_cas(l)= vq_prof_cas(k2) - frac*(vq_prof_cas(k2)-vq_prof_cas(k1))2806 dtrad_mod_cas(l)= dtrad_prof_cas(k2) - frac*(dtrad_prof_cas(k2)-dtrad_prof_cas(k1))2807 2808 else !play>plev_prof_cas(1)2809 2810 k1=12811 k2=22812 frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))2813 frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))2814 t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)2815 q_mod_cas(l)= frac1*q_prof_cas(k1) - frac2*q_prof_cas(k2)2816 u_mod_cas(l)= frac1*u_prof_cas(k1) - frac2*u_prof_cas(k2)2817 v_mod_cas(l)= frac1*v_prof_cas(k1) - frac2*v_prof_cas(k2)2818 ug_mod_cas(l)= frac1*ug_prof_cas(k1) - frac2*ug_prof_cas(k2)2819 vg_mod_cas(l)= frac1*vg_prof_cas(k1) - frac2*vg_prof_cas(k2)2820 w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_prof_cas(k2)2821 du_mod_cas(l)= frac1*du_prof_cas(k1) - frac2*du_prof_cas(k2)2822 hu_mod_cas(l)= frac1*hu_prof_cas(k1) - frac2*hu_prof_cas(k2)2823 vu_mod_cas(l)= frac1*vu_prof_cas(k1) - frac2*vu_prof_cas(k2)2824 dv_mod_cas(l)= frac1*dv_prof_cas(k1) - frac2*dv_prof_cas(k2)2825 hv_mod_cas(l)= frac1*hv_prof_cas(k1) - frac2*hv_prof_cas(k2)2826 vv_mod_cas(l)= frac1*vv_prof_cas(k1) - frac2*vv_prof_cas(k2)2827 dt_mod_cas(l)= frac1*dt_prof_cas(k1) - frac2*dt_prof_cas(k2)2828 ht_mod_cas(l)= frac1*ht_prof_cas(k1) - frac2*ht_prof_cas(k2)2829 vt_mod_cas(l)= frac1*vt_prof_cas(k1) - frac2*vt_prof_cas(k2)2830 dq_mod_cas(l)= frac1*dq_prof_cas(k1) - frac2*dq_prof_cas(k2)2831 hq_mod_cas(l)= frac1*hq_prof_cas(k1) - frac2*hq_prof_cas(k2)2832 vq_mod_cas(l)= frac1*vq_prof_cas(k1) - frac2*vq_prof_cas(k2)2833 dtrad_mod_cas(l)= frac1*dtrad_prof_cas(k1) - frac2*dtrad_prof_cas(k2)2834 2835 endif ! play.le.plev_prof_cas(1)2836 2837 else ! above max altitude of forcing file2838 2839 !jyg2840 fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg2841 fact = max(fact,0.) !jyg2842 fact = exp(-fact) !jyg2843 t_mod_cas(l)= t_prof_cas(nlev_cas) !jyg2844 q_mod_cas(l)= q_prof_cas(nlev_cas)*fact !jyg2845 u_mod_cas(l)= u_prof_cas(nlev_cas)*fact !jyg2846 v_mod_cas(l)= v_prof_cas(nlev_cas)*fact !jyg2847 ug_mod_cas(l)= ug_prof_cas(nlev_cas)*fact !jyg2848 vg_mod_cas(l)= vg_prof_cas(nlev_cas)*fact !jyg2849 w_mod_cas(l)= 0.0 !jyg2850 du_mod_cas(l)= du_prof_cas(nlev_cas)*fact2851 hu_mod_cas(l)= hu_prof_cas(nlev_cas)*fact !jyg2852 vu_mod_cas(l)= vu_prof_cas(nlev_cas)*fact !jyg2853 dv_mod_cas(l)= dv_prof_cas(nlev_cas)*fact2854 hv_mod_cas(l)= hv_prof_cas(nlev_cas)*fact !jyg2855 vv_mod_cas(l)= vv_prof_cas(nlev_cas)*fact !jyg2856 dt_mod_cas(l)= dt_prof_cas(nlev_cas)2857 ht_mod_cas(l)= ht_prof_cas(nlev_cas) !jyg2858 vt_mod_cas(l)= vt_prof_cas(nlev_cas) !jyg2859 dq_mod_cas(l)= dq_prof_cas(nlev_cas)*fact2860 hq_mod_cas(l)= hq_prof_cas(nlev_cas)*fact !jyg2861 vq_mod_cas(l)= vq_prof_cas(nlev_cas)*fact !jyg2862 dtrad_mod_cas(l)= dtrad_prof_cas(nlev_cas)*fact !jyg2863 2864 endif ! play2865 2866 enddo ! l2867 2868 ! do l = 1,llm2869 ! print *,'t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l) ',2870 ! $ l,t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l)2871 ! enddo2872 2873 return2874 end2875 !*****************************************************************************2876 !=====================================================================2877 SUBROUTINE interp_dice_vertical(play,nlev_dice,nt_dice,plev_prof &2878 & ,th_prof,qv_prof,u_prof,v_prof,o3_prof &2879 & ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof &2880 & ,th_mod,qv_mod,u_mod,v_mod,o3_mod &2881 & ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)2882 2883 implicit none2884 2885 #include "dimensions.h"2886 2887 !-------------------------------------------------------------------------2888 ! Vertical interpolation of Dice forcing data onto model levels2889 !-------------------------------------------------------------------------2890 2891 integer nlevmax2892 parameter (nlevmax=41)2893 integer nlev_dice,mxcalc,nt_dice2894 2895 real play(llm), plev_prof(nlev_dice)2896 real th_prof(nlev_dice),qv_prof(nlev_dice)2897 real u_prof(nlev_dice),v_prof(nlev_dice)2898 real o3_prof(nlev_dice)2899 real ht_prof(nlev_dice),hq_prof(nlev_dice)2900 real hu_prof(nlev_dice),hv_prof(nlev_dice)2901 real w_prof(nlev_dice),omega_prof(nlev_dice)2902 2903 real th_mod(llm),qv_mod(llm)2904 real u_mod(llm),v_mod(llm), o3_mod(llm)2905 real ht_mod(llm),hq_mod(llm)2906 real hu_mod(llm),hv_mod(llm),w_mod(llm),omega_mod(llm)2907 2908 integer l,k,k1,k2,kp2909 real aa,frac,frac1,frac2,fact2910 2911 do l = 1, llm2912 2913 if (play(l).ge.plev_prof(nlev_dice)) then2914 2915 mxcalc=l2916 k1=02917 k2=02918 2919 if (play(l).le.plev_prof(1)) then2920 2921 do k = 1, nlev_dice-12922 if (play(l).le.plev_prof(k) .and. play(l).gt.plev_prof(k+1)) then2923 k1=k2924 k2=k+12925 endif2926 enddo2927 2928 if (k1.eq.0 .or. k2.eq.0) then2929 write(*,*) 'PB! k1, k2 = ',k1,k22930 write(*,*) 'l,play(l) = ',l,play(l)/1002931 do k = 1, nlev_dice-12932 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002933 enddo2934 endif2935 2936 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2937 th_mod(l)= th_prof(k2) - frac*(th_prof(k2)-th_prof(k1))2938 qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))2939 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2940 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2941 o3_mod(l)= o3_prof(k2) - frac*(o3_prof(k2)-o3_prof(k1))2942 ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))2943 hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))2944 hu_mod(l)= hu_prof(k2) - frac*(hu_prof(k2)-hu_prof(k1))2945 hv_mod(l)= hv_prof(k2) - frac*(hv_prof(k2)-hv_prof(k1))2946 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2947 omega_mod(l)= omega_prof(k2) - frac*(omega_prof(k2)-omega_prof(k1))2948 2949 else !play>plev_prof(1)2950 2951 k1=12952 k2=22953 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2954 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2955 th_mod(l)= frac1*th_prof(k1) - frac2*th_prof(k2)2956 qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)2957 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2958 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2959 o3_mod(l)= frac1*o3_prof(k1) - frac2*o3_prof(k2)2960 ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)2961 hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)2962 hu_mod(l)= frac1*hu_prof(k1) - frac2*hu_prof(k2)2963 hv_mod(l)= frac1*hv_prof(k1) - frac2*hv_prof(k2)2964 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2965 omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)2966 2967 endif ! play.le.plev_prof(1)2968 2969 else ! above max altitude of forcing file2970 2971 !jyg2972 fact=20.*(plev_prof(nlev_dice)-play(l))/plev_prof(nlev_dice) !jyg2973 fact = max(fact,0.) !jyg2974 fact = exp(-fact) !jyg2975 th_mod(l)= th_prof(nlev_dice) !jyg2976 qv_mod(l)= qv_prof(nlev_dice)*fact !jyg2977 u_mod(l)= u_prof(nlev_dice)*fact !jyg2978 v_mod(l)= v_prof(nlev_dice)*fact !jyg2979 o3_mod(l)= o3_prof(nlev_dice)*fact !jyg2980 ht_mod(l)= ht_prof(nlev_dice) !jyg2981 hq_mod(l)= hq_prof(nlev_dice)*fact !jyg2982 hu_mod(l)= hu_prof(nlev_dice) !jyg2983 hv_mod(l)= hv_prof(nlev_dice) !jyg2984 w_mod(l)= 0. !jyg2985 omega_mod(l)= 0. !jyg2986 2987 endif ! play2988 2989 enddo ! l2990 2991 ! do l = 1,llm2992 ! print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',2993 ! $ l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)2994 ! enddo2995 2996 return2997 end2998 2999 !======================================================================3000 SUBROUTINE interp_astex_time(day,day1,annee_ref &3001 & ,year_ini_astex,day_ini_astex,nt_astex,dt_astex &3002 & ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex &3003 & ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof &3004 & ,ufa_prof,vfa_prof)3005 implicit none3006 3007 !---------------------------------------------------------------------------------------3008 ! Time interpolation of a 2D field to the timestep corresponding to day3009 !3010 ! day: current julian day (e.g. 717538.2)3011 ! day1: first day of the simulation3012 ! nt_astex: total nb of data in the forcing (e.g. 41 for Astex)3013 ! dt_astex: total time interval (in sec) between 2 forcing data (e.g. 1h for Astex)3014 !---------------------------------------------------------------------------------------3015 3016 ! inputs:3017 integer annee_ref3018 integer nt_astex,nlev_astex3019 integer year_ini_astex3020 real day, day1,day_ini_astex,dt_astex3021 real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)3022 real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)3023 ! outputs:3024 real div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof3025 ! local:3026 integer it_astex1, it_astex23027 real timeit,time_astex1,time_astex2,frac3028 3029 ! Check that initial day of the simulation consistent with ASTEX period:3030 if (annee_ref.ne.1992 ) then3031 print*,'Pour Astex, annee_ref doit etre 1992 '3032 print*,'Changer annee_ref dans run.def'3033 stop3034 endif3035 if (annee_ref.eq.1992 .and. day1.lt.day_ini_astex) then3036 print*,'Astex debute le 13 Juin 1992 (jour julien=165)'3037 print*,'Changer dayref dans run.def'3038 stop3039 endif3040 3041 ! Determine timestep relative to the 1st day of TOGA-COARE:3042 ! timeit=(day-day1)*86400.3043 ! if (annee_ref.eq.1992) then3044 ! timeit=(day-day_ini_astex)*86400.3045 ! else3046 ! timeit=(day+2.-1.)*86400. ! 2 days between Jun13 and Jun15 19923047 ! endif3048 timeit=(day-day_ini_astex)*864003049 3050 ! Determine the closest observation times:3051 it_astex1=INT(timeit/dt_astex)+13052 it_astex2=it_astex1 + 13053 time_astex1=(it_astex1-1)*dt_astex3054 time_astex2=(it_astex2-1)*dt_astex3055 print *,'timeit day day_ini_astex',timeit,day,day_ini_astex3056 print *,'it_astex1,it_astex2,time_astex1,time_astex2', &3057 & it_astex1,it_astex2,time_astex1,time_astex23058 3059 if (it_astex1 .ge. nt_astex) then3060 write(*,*) 'PB-stop: day, it_astex1, it_astex2, timeit: ' &3061 & ,day,it_astex1,it_astex2,timeit/86400.3062 stop3063 endif3064 3065 ! time interpolation:3066 frac=(time_astex2-timeit)/(time_astex2-time_astex1)3067 frac=max(frac,0.0)3068 3069 div_prof = div_astex(it_astex2) &3070 & -frac*(div_astex(it_astex2)-div_astex(it_astex1))3071 ts_prof = ts_astex(it_astex2) &3072 & -frac*(ts_astex(it_astex2)-ts_astex(it_astex1))3073 ug_prof = ug_astex(it_astex2) &3074 & -frac*(ug_astex(it_astex2)-ug_astex(it_astex1))3075 vg_prof = vg_astex(it_astex2) &3076 & -frac*(vg_astex(it_astex2)-vg_astex(it_astex1))3077 ufa_prof = ufa_astex(it_astex2) &3078 & -frac*(ufa_astex(it_astex2)-ufa_astex(it_astex1))3079 vfa_prof = vfa_astex(it_astex2) &3080 & -frac*(vfa_astex(it_astex2)-vfa_astex(it_astex1))3081 3082 print*, &3083 &'day,annee_ref,day_ini_astex,timeit,it_astex1,it_astex2,SST:', &3084 &day,annee_ref,day_ini_astex,timeit/86400.,it_astex1, &3085 &it_astex2,div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof3086 3087 return3088 END3089 3090 !======================================================================3091 SUBROUTINE interp_toga_time(day,day1,annee_ref &3092 & ,year_ini_toga,day_ini_toga,nt_toga,dt_toga,nlev_toga &3093 & ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga &3094 & ,ht_toga,vt_toga,hq_toga,vq_toga &3095 & ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof &3096 & ,ht_prof,vt_prof,hq_prof,vq_prof)3097 implicit none3098 3099 !---------------------------------------------------------------------------------------3100 ! Time interpolation of a 2D field to the timestep corresponding to day3101 !3102 ! day: current julian day (e.g. 717538.2)3103 ! day1: first day of the simulation3104 ! nt_toga: total nb of data in the forcing (e.g. 480 for TOGA-COARE)3105 ! dt_toga: total time interval (in sec) between 2 forcing data (e.g. 6h for TOGA-COARE)3106 !---------------------------------------------------------------------------------------3107 3108 #include "compar1d.h"3109 3110 ! inputs:3111 integer annee_ref3112 integer nt_toga,nlev_toga3113 integer year_ini_toga3114 real day, day1,day_ini_toga,dt_toga3115 real ts_toga(nt_toga)3116 real plev_toga(nlev_toga,nt_toga),t_toga(nlev_toga,nt_toga)3117 real q_toga(nlev_toga,nt_toga),u_toga(nlev_toga,nt_toga)3118 real v_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)3119 real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)3120 real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)3121 ! outputs:3122 real ts_prof3123 real plev_prof(nlev_toga),t_prof(nlev_toga)3124 real q_prof(nlev_toga),u_prof(nlev_toga)3125 real v_prof(nlev_toga),w_prof(nlev_toga)3126 real ht_prof(nlev_toga),vt_prof(nlev_toga)3127 real hq_prof(nlev_toga),vq_prof(nlev_toga)3128 ! local:3129 integer it_toga1, it_toga2,k3130 real timeit,time_toga1,time_toga2,frac3131 3132 3133 if (forcing_type.eq.2) then3134 ! Check that initial day of the simulation consistent with TOGA-COARE period:3135 if (annee_ref.ne.1992 .and. annee_ref.ne.1993) then3136 print*,'Pour TOGA-COARE, annee_ref doit etre 1992 ou 1993'3137 print*,'Changer annee_ref dans run.def'3138 stop3139 endif3140 if (annee_ref.eq.1992 .and. day1.lt.day_ini_toga) then3141 print*,'TOGA-COARE a debute le 1er Nov 1992 (jour julien=306)'3142 print*,'Changer dayref dans run.def'3143 stop3144 endif3145 if (annee_ref.eq.1993 .and. day1.gt.day_ini_toga+119) then3146 print*,'TOGA-COARE a fini le 28 Feb 1993 (jour julien=59)'3147 print*,'Changer dayref ou nday dans run.def'3148 stop3149 endif3150 3151 else if (forcing_type.eq.4) then3152 3153 ! Check that initial day of the simulation consistent with TWP-ICE period:3154 if (annee_ref.ne.2006) then3155 print*,'Pour TWP-ICE, annee_ref doit etre 2006'3156 print*,'Changer annee_ref dans run.def'3157 stop3158 endif3159 if (annee_ref.eq.2006 .and. day1.lt.day_ini_toga) then3160 print*,'TWP-ICE a debute le 17 Jan 2006 (jour julien=17)'3161 print*,'Changer dayref dans run.def'3162 stop3163 endif3164 if (annee_ref.eq.2006 .and. day1.gt.day_ini_toga+26) then3165 print*,'TWP-ICE a fini le 12 Feb 2006 (jour julien=43)'3166 print*,'Changer dayref ou nday dans run.def'3167 stop3168 endif3169 3170 endif3171 3172 ! Determine timestep relative to the 1st day of TOGA-COARE:3173 ! timeit=(day-day1)*86400.3174 ! if (annee_ref.eq.1992) then3175 ! timeit=(day-day_ini_toga)*86400.3176 ! else3177 ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 19923178 ! endif3179 timeit=(day-day_ini_toga)*864003180 3181 ! Determine the closest observation times:3182 it_toga1=INT(timeit/dt_toga)+13183 it_toga2=it_toga1 + 13184 time_toga1=(it_toga1-1)*dt_toga3185 time_toga2=(it_toga2-1)*dt_toga3186 3187 if (it_toga1 .ge. nt_toga) then3188 write(*,*) 'PB-stop: day, it_toga1, it_toga2, timeit: ' &3189 & ,day,it_toga1,it_toga2,timeit/86400.3190 stop3191 endif3192 3193 ! time interpolation:3194 frac=(time_toga2-timeit)/(time_toga2-time_toga1)3195 frac=max(frac,0.0)3196 3197 ts_prof = ts_toga(it_toga2) &3198 & -frac*(ts_toga(it_toga2)-ts_toga(it_toga1))3199 3200 ! print*,3201 ! :'day,annee_ref,day_ini_toga,timeit,it_toga1,it_toga2,SST:',3202 ! :day,annee_ref,day_ini_toga,timeit/86400.,it_toga1,it_toga2,ts_prof3203 3204 do k=1,nlev_toga3205 plev_prof(k) = 100.*(plev_toga(k,it_toga2) &3206 & -frac*(plev_toga(k,it_toga2)-plev_toga(k,it_toga1)))3207 t_prof(k) = t_toga(k,it_toga2) &3208 & -frac*(t_toga(k,it_toga2)-t_toga(k,it_toga1))3209 q_prof(k) = q_toga(k,it_toga2) &3210 & -frac*(q_toga(k,it_toga2)-q_toga(k,it_toga1))3211 u_prof(k) = u_toga(k,it_toga2) &3212 & -frac*(u_toga(k,it_toga2)-u_toga(k,it_toga1))3213 v_prof(k) = v_toga(k,it_toga2) &3214 & -frac*(v_toga(k,it_toga2)-v_toga(k,it_toga1))3215 w_prof(k) = w_toga(k,it_toga2) &3216 & -frac*(w_toga(k,it_toga2)-w_toga(k,it_toga1))3217 ht_prof(k) = ht_toga(k,it_toga2) &3218 & -frac*(ht_toga(k,it_toga2)-ht_toga(k,it_toga1))3219 vt_prof(k) = vt_toga(k,it_toga2) &3220 & -frac*(vt_toga(k,it_toga2)-vt_toga(k,it_toga1))3221 hq_prof(k) = hq_toga(k,it_toga2) &3222 & -frac*(hq_toga(k,it_toga2)-hq_toga(k,it_toga1))3223 vq_prof(k) = vq_toga(k,it_toga2) &3224 & -frac*(vq_toga(k,it_toga2)-vq_toga(k,it_toga1))3225 enddo3226 3227 return3228 END3229 3230 !======================================================================3231 SUBROUTINE interp_dice_time(day,day1,annee_ref &3232 & ,year_ini_dice,day_ini_dice,nt_dice,dt_dice &3233 & ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice &3234 & ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice &3235 & ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice &3236 & ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof &3237 & ,ustar_prof,psurf_prof,ug_prof,vg_prof &3238 & ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof)3239 implicit none3240 3241 !---------------------------------------------------------------------------------------3242 ! Time interpolation of a 2D field to the timestep corresponding to day3243 !3244 ! day: current julian day (e.g. 717538.2)3245 ! day1: first day of the simulation3246 ! nt_dice: total nb of data in the forcing (e.g. 145 for Dice)3247 ! dt_dice: total time interval (in sec) between 2 forcing data (e.g. 30min. for Dice)3248 !---------------------------------------------------------------------------------------3249 3250 #include "compar1d.h"3251 3252 ! inputs:3253 integer annee_ref3254 integer nt_dice,nlev_dice3255 integer year_ini_dice3256 real day, day1,day_ini_dice,dt_dice3257 real shf_dice(nt_dice),lhf_dice(nt_dice),lwup_dice(nt_dice)3258 real swup_dice(nt_dice),tg_dice(nt_dice),ustar_dice(nt_dice)3259 real psurf_dice(nt_dice),ug_dice(nt_dice),vg_dice(nt_dice)3260 real ht_dice(nlev_dice,nt_dice),hq_dice(nlev_dice,nt_dice)3261 real hu_dice(nlev_dice,nt_dice),hv_dice(nlev_dice,nt_dice)3262 real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)3263 ! outputs:3264 real tg_prof,shf_prof,lhf_prof,lwup_prof,swup_prof3265 real ustar_prof,psurf_prof,ug_prof,vg_prof3266 real ht_prof(nlev_dice),hq_prof(nlev_dice)3267 real hu_prof(nlev_dice),hv_prof(nlev_dice)3268 real w_prof(nlev_dice),omega_prof(nlev_dice)3269 ! local:3270 integer it_dice1, it_dice2,k3271 real timeit,time_dice1,time_dice2,frac3272 3273 3274 if (forcing_type.eq.7) then3275 ! Check that initial day of the simulation consistent with Dice period:3276 print *,'annee_ref=',annee_ref3277 print *,'day1=',day13278 print *,'day_ini_dice=',day_ini_dice3279 if (annee_ref.ne.1999) then3280 print*,'Pour Dice, annee_ref doit etre 1999'3281 print*,'Changer annee_ref dans run.def'3282 stop3283 endif3284 if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice) then3285 print*,'Dice a debute le 23 Oct 1999 (jour julien=296)'3286 print*,'Changer dayref dans run.def',day1,day_ini_dice3287 stop3288 endif3289 if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice+2) then3290 print*,'Dice a fini le 25 Oct 1999 (jour julien=298)'3291 print*,'Changer dayref ou nday dans run.def',day1,day_ini_dice3292 stop3293 endif3294 3295 endif3296 3297 ! Determine timestep relative to the 1st day of TOGA-COARE:3298 ! timeit=(day-day1)*86400.3299 ! if (annee_ref.eq.1992) then3300 ! timeit=(day-day_ini_dice)*86400.3301 ! else3302 ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 19923303 ! endif3304 timeit=(day-day_ini_dice)*864003305 3306 ! Determine the closest observation times:3307 it_dice1=INT(timeit/dt_dice)+13308 it_dice2=it_dice1 + 13309 time_dice1=(it_dice1-1)*dt_dice3310 time_dice2=(it_dice2-1)*dt_dice3311 3312 if (it_dice1 .ge. nt_dice) then3313 write(*,*) 'PB-stop: day, it_dice1, it_dice2, timeit: ',day,it_dice1,it_dice2,timeit/86400.3314 stop3315 endif3316 3317 ! time interpolation:3318 frac=(time_dice2-timeit)/(time_dice2-time_dice1)3319 frac=max(frac,0.0)3320 3321 shf_prof = shf_dice(it_dice2)-frac*(shf_dice(it_dice2)-shf_dice(it_dice1))3322 lhf_prof = lhf_dice(it_dice2)-frac*(lhf_dice(it_dice2)-lhf_dice(it_dice1))3323 lwup_prof = lwup_dice(it_dice2)-frac*(lwup_dice(it_dice2)-lwup_dice(it_dice1))3324 swup_prof = swup_dice(it_dice2)-frac*(swup_dice(it_dice2)-swup_dice(it_dice1))3325 tg_prof = tg_dice(it_dice2)-frac*(tg_dice(it_dice2)-tg_dice(it_dice1))3326 ustar_prof = ustar_dice(it_dice2)-frac*(ustar_dice(it_dice2)-ustar_dice(it_dice1))3327 psurf_prof = psurf_dice(it_dice2)-frac*(psurf_dice(it_dice2)-psurf_dice(it_dice1))3328 ug_prof = ug_dice(it_dice2)-frac*(ug_dice(it_dice2)-ug_dice(it_dice1))3329 vg_prof = vg_dice(it_dice2)-frac*(vg_dice(it_dice2)-vg_dice(it_dice1))3330 3331 ! print*,3332 ! :'day,annee_ref,day_ini_dice,timeit,it_dice1,it_dice2,SST:',3333 ! :day,annee_ref,day_ini_dice,timeit/86400.,it_dice1,it_dice2,ts_prof3334 3335 do k=1,nlev_dice3336 ht_prof(k) = ht_dice(k,it_dice2)-frac*(ht_dice(k,it_dice2)-ht_dice(k,it_dice1))3337 hq_prof(k) = hq_dice(k,it_dice2)-frac*(hq_dice(k,it_dice2)-hq_dice(k,it_dice1))3338 hu_prof(k) = hu_dice(k,it_dice2)-frac*(hu_dice(k,it_dice2)-hu_dice(k,it_dice1))3339 hv_prof(k) = hv_dice(k,it_dice2)-frac*(hv_dice(k,it_dice2)-hv_dice(k,it_dice1))3340 w_prof(k) = w_dice(k,it_dice2)-frac*(w_dice(k,it_dice2)-w_dice(k,it_dice1))3341 omega_prof(k) = omega_dice(k,it_dice2)-frac*(omega_dice(k,it_dice2)-omega_dice(k,it_dice1))3342 enddo3343 3344 return3345 END3346 3347 !======================================================================3348 SUBROUTINE interp_gabls4_time(day,day1,annee_ref &3349 & ,year_ini_gabls4,day_ini_gabls4,nt_gabls4,dt_gabls4,nlev_gabls4 &3350 & ,ug_gabls4,vg_gabls4,ht_gabls4,hq_gabls4,tg_gabls4 &3351 & ,ug_prof,vg_prof,ht_prof,hq_prof,tg_prof)3352 implicit none3353 3354 !---------------------------------------------------------------------------------------3355 ! Time interpolation of a 2D field to the timestep corresponding to day3356 !3357 ! day: current julian day3358 ! day1: first day of the simulation3359 ! nt_gabls4: total nb of data in the forcing (e.g. 37 for gabls4)3360 ! dt_gabls4: total time interval (in sec) between 2 forcing data (e.g. 60min. for gabls4)3361 !---------------------------------------------------------------------------------------3362 3363 #include "compar1d.h"3364 3365 ! inputs:3366 integer annee_ref3367 integer nt_gabls4,nlev_gabls43368 integer year_ini_gabls43369 real day, day1,day_ini_gabls4,dt_gabls43370 real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4)3371 real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4)3372 real tg_gabls4(nt_gabls4), tg_prof3373 ! outputs:3374 real ug_prof(nlev_gabls4),vg_prof(nlev_gabls4)3375 real ht_prof(nlev_gabls4),hq_prof(nlev_gabls4)3376 ! local:3377 integer it_gabls41, it_gabls42,k3378 real timeit,time_gabls41,time_gabls42,frac3379 3380 3381 3382 ! Check that initial day of the simulation consistent with gabls4 period:3383 if (forcing_type.eq.8 ) then3384 print *,'annee_ref=',annee_ref3385 print *,'day1=',day13386 print *,'day_ini_gabls4=',day_ini_gabls43387 if (annee_ref.ne.2009) then3388 print*,'Pour gabls4, annee_ref doit etre 2009'3389 print*,'Changer annee_ref dans run.def'3390 stop3391 endif3392 if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4) then3393 print*,'gabls4 a debute le 11 dec 2009 (jour julien=345)'3394 print*,'Changer dayref dans run.def',day1,day_ini_gabls43395 stop3396 endif3397 if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4+2) then3398 print*,'gabls4 a fini le 12 dec 2009 (jour julien=346)'3399 print*,'Changer dayref ou nday dans run.def',day1,day_ini_gabls43400 stop3401 endif3402 endif3403 3404 timeit=(day-day_ini_gabls4)*864003405 print *,'day,day_ini_gabls4=',day,day_ini_gabls43406 print *,'nt_gabls4,dt,timeit=',nt_gabls4,dt_gabls4,timeit3407 3408 ! Determine the closest observation times:3409 it_gabls41=INT(timeit/dt_gabls4)+13410 it_gabls42=it_gabls41 + 13411 time_gabls41=(it_gabls41-1)*dt_gabls43412 time_gabls42=(it_gabls42-1)*dt_gabls43413 3414 if (it_gabls41 .ge. nt_gabls4) then3415 write(*,*) 'PB-stop: day, it_gabls41, it_gabls42, timeit: ',day,it_gabls41,it_gabls42,timeit/86400.3416 stop3417 endif3418 3419 ! time interpolation:3420 frac=(time_gabls42-timeit)/(time_gabls42-time_gabls41)3421 frac=max(frac,0.0)3422 3423 3424 do k=1,nlev_gabls43425 ug_prof(k) = ug_gabls4(k,it_gabls42)-frac*(ug_gabls4(k,it_gabls42)-ug_gabls4(k,it_gabls41))3426 vg_prof(k) = vg_gabls4(k,it_gabls42)-frac*(vg_gabls4(k,it_gabls42)-vg_gabls4(k,it_gabls41))3427 ht_prof(k) = ht_gabls4(k,it_gabls42)-frac*(ht_gabls4(k,it_gabls42)-ht_gabls4(k,it_gabls41))3428 hq_prof(k) = hq_gabls4(k,it_gabls42)-frac*(hq_gabls4(k,it_gabls42)-hq_gabls4(k,it_gabls41))3429 enddo3430 tg_prof=tg_gabls4(it_gabls42)-frac*(tg_gabls4(it_gabls42)-tg_gabls4(it_gabls41))3431 return3432 END3433 3434 !======================================================================3435 SUBROUTINE interp_armcu_time(day,day1,annee_ref &3436 & ,year_ini_armcu,day_ini_armcu,nt_armcu,dt_armcu &3437 & ,nlev_armcu,fs_armcu,fl_armcu,at_armcu,rt_armcu &3438 & ,aqt_armcu,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof)3439 implicit none3440 3441 !---------------------------------------------------------------------------------------3442 ! Time interpolation of a 2D field to the timestep corresponding to day3443 !3444 ! day: current julian day (e.g. 717538.2)3445 ! day1: first day of the simulation3446 ! nt_armcu: total nb of data in the forcing (e.g. 31 for armcu)3447 ! dt_armcu: total time interval (in sec) between 2 forcing data (e.g. 1/2h for armcu)3448 ! fs= sensible flux3449 ! fl= latent flux3450 ! at,rt,aqt= advective and radiative tendencies3451 !---------------------------------------------------------------------------------------3452 3453 ! inputs:3454 integer annee_ref3455 integer nt_armcu,nlev_armcu3456 integer year_ini_armcu3457 real day, day1,day_ini_armcu,dt_armcu3458 real fs_armcu(nt_armcu),fl_armcu(nt_armcu),at_armcu(nt_armcu)3459 real rt_armcu(nt_armcu),aqt_armcu(nt_armcu)3460 ! outputs:3461 real fs_prof,fl_prof,at_prof,rt_prof,aqt_prof3462 ! local:3463 integer it_armcu1, it_armcu2,k3464 real timeit,time_armcu1,time_armcu2,frac3465 3466 ! Check that initial day of the simulation consistent with ARMCU period:3467 if (annee_ref.ne.1997 ) then3468 print*,'Pour ARMCU, annee_ref doit etre 1997 '3469 print*,'Changer annee_ref dans run.def'3470 stop3471 endif3472 3473 timeit=(day-day_ini_armcu)*864003474 3475 ! Determine the closest observation times:3476 it_armcu1=INT(timeit/dt_armcu)+13477 it_armcu2=it_armcu1 + 13478 time_armcu1=(it_armcu1-1)*dt_armcu3479 time_armcu2=(it_armcu2-1)*dt_armcu3480 print *,'timeit day day_ini_armcu',timeit,day,day_ini_armcu3481 print *,'it_armcu1,it_armcu2,time_armcu1,time_armcu2', &3482 & it_armcu1,it_armcu2,time_armcu1,time_armcu23483 3484 if (it_armcu1 .ge. nt_armcu) then3485 write(*,*) 'PB-stop: day, it_armcu1, it_armcu2, timeit: ' &3486 & ,day,it_armcu1,it_armcu2,timeit/86400.3487 stop3488 endif3489 3490 ! time interpolation:3491 frac=(time_armcu2-timeit)/(time_armcu2-time_armcu1)3492 frac=max(frac,0.0)3493 3494 fs_prof = fs_armcu(it_armcu2) &3495 & -frac*(fs_armcu(it_armcu2)-fs_armcu(it_armcu1))3496 fl_prof = fl_armcu(it_armcu2) &3497 & -frac*(fl_armcu(it_armcu2)-fl_armcu(it_armcu1))3498 at_prof = at_armcu(it_armcu2) &3499 & -frac*(at_armcu(it_armcu2)-at_armcu(it_armcu1))3500 rt_prof = rt_armcu(it_armcu2) &3501 & -frac*(rt_armcu(it_armcu2)-rt_armcu(it_armcu1))3502 aqt_prof = aqt_armcu(it_armcu2) &3503 & -frac*(aqt_armcu(it_armcu2)-aqt_armcu(it_armcu1))3504 3505 print*, &3506 &'day,annee_ref,day_ini_armcu,timeit,it_armcu1,it_armcu2,SST:', &3507 &day,annee_ref,day_ini_armcu,timeit/86400.,it_armcu1, &3508 &it_armcu2,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof3509 3510 return3511 END3512 3513 !=====================================================================3514 subroutine readprofiles(nlev_max,kmax,ntrac,height, &3515 & thlprof,qtprof,uprof, &3516 & vprof,e12prof,ugprof,vgprof, &3517 & wfls,dqtdxls,dqtdyls,dqtdtls, &3518 & thlpcar,tracer,nt1,nt2)3519 implicit none3520 3521 integer nlev_max,kmax,kmax2,ntrac3522 logical :: llesread = .true.3523 3524 real height(nlev_max),thlprof(nlev_max),qtprof(nlev_max), &3525 & uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max), &3526 & ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max), &3527 & dqtdxls(nlev_max),dqtdyls(nlev_max),dqtdtls(nlev_max), &3528 & thlpcar(nlev_max),tracer(nlev_max,ntrac)3529 3530 real height1(nlev_max)3531 3532 integer, parameter :: ilesfile=13533 integer :: ierr,k,itrac,nt1,nt23534 3535 if(.not.(llesread)) return3536 3537 open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)3538 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3539 read (ilesfile,*) kmax3540 do k=1,kmax3541 read (ilesfile,*) height1(k),thlprof(k),qtprof (k), &3542 & uprof (k),vprof (k),e12prof(k)3543 enddo3544 close(ilesfile)3545 3546 open(ilesfile,file='lscale.inp.001',status='old',iostat=ierr)3547 if (ierr /= 0) stop 'ERROR:Lscale.inp does not exist'3548 read (ilesfile,*) kmax23549 if (kmax .ne. kmax2) then3550 print *, 'fichiers prof.inp et lscale.inp incompatibles :'3551 print *, 'nbre de niveaux : ',kmax,' et ',kmax23552 stop 'lecture profiles'3553 endif3554 do k=1,kmax3555 read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k), &3556 & dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k)3557 end do3558 do k=1,kmax3559 if (height(k) .ne. height1(k)) then3560 print *, 'fichiers prof.inp et lscale.inp incompatibles :'3561 print *, 'les niveaux different : ',k,height1(k), height(k)3562 stop3563 endif3564 end do3565 close(ilesfile)3566 3567 open(ilesfile,file='trac.inp.001',status='old',iostat=ierr)3568 if (ierr /= 0) then3569 print*,'WARNING : trac.inp does not exist'3570 else3571 read (ilesfile,*) kmax2,nt1,nt23572 if (nt2>ntrac) then3573 stop 'Augmenter le nombre de traceurs dans traceur.def'3574 endif3575 if (kmax .ne. kmax2) then3576 print *, 'fichiers prof.inp et lscale.inp incompatibles :'3577 print *, 'nbre de niveaux : ',kmax,' et ',kmax23578 stop 'lecture profiles'3579 endif3580 do k=1,kmax3581 read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2)3582 end do3583 close(ilesfile)3584 endif3585 3586 return3587 end3588 !======================================================================3589 subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof, &3590 & thlprof,qprof,uprof,vprof,wprof,omega,o3mmr)3591 !======================================================================3592 implicit none3593 3594 integer nlev_max,kmax3595 logical :: llesread = .true.3596 3597 real height(nlev_max),pprof(nlev_max),tprof(nlev_max)3598 real thlprof(nlev_max)3599 real qprof(nlev_max),uprof(nlev_max),vprof(nlev_max)3600 real wprof(nlev_max),omega(nlev_max),o3mmr(nlev_max)3601 3602 integer, parameter :: ilesfile=13603 integer :: k,ierr3604 3605 if(.not.(llesread)) return3606 3607 open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)3608 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3609 read (ilesfile,*) kmax3610 do k=1,kmax3611 read (ilesfile,*) height(k),pprof(k), tprof(k),thlprof(k), &3612 & qprof (k),uprof(k), vprof(k), wprof(k), &3613 & omega (k),o3mmr(k)3614 enddo3615 close(ilesfile)3616 3617 return3618 end3619 3620 !======================================================================3621 subroutine readprofile_astex(nlev_max,kmax,height,pprof,tprof, &3622 & thlprof,qvprof,qlprof,qtprof,uprof,vprof,wprof,tkeprof,o3mmr)3623 !======================================================================3624 implicit none3625 3626 integer nlev_max,kmax3627 logical :: llesread = .true.3628 3629 real height(nlev_max),pprof(nlev_max),tprof(nlev_max), &3630 & thlprof(nlev_max),qlprof(nlev_max),qtprof(nlev_max), &3631 & qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max), &3632 & wprof(nlev_max),tkeprof(nlev_max),o3mmr(nlev_max)3633 3634 integer, parameter :: ilesfile=13635 integer :: ierr,k3636 3637 if(.not.(llesread)) return3638 3639 open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)3640 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3641 read (ilesfile,*) kmax3642 do k=1,kmax3643 read (ilesfile,*) height(k),pprof(k), tprof(k),thlprof(k), &3644 & qvprof (k),qlprof (k),qtprof (k), &3645 & uprof(k), vprof(k), wprof(k),tkeprof(k),o3mmr(k)3646 enddo3647 close(ilesfile)3648 3649 return3650 end3651 3652 3653 3654 !======================================================================3655 subroutine readprofile_armcu(nlev_max,kmax,height,pprof,uprof, &3656 & vprof,thetaprof,tprof,qvprof,rvprof,aprof,bprof)3657 !======================================================================3658 implicit none3659 3660 integer nlev_max,kmax3661 logical :: llesread = .true.3662 3663 real height(nlev_max),pprof(nlev_max),tprof(nlev_max)3664 real thetaprof(nlev_max),rvprof(nlev_max)3665 real qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max)3666 real aprof(nlev_max+1),bprof(nlev_max+1)3667 3668 integer, parameter :: ilesfile=13669 integer, parameter :: ifile=23670 integer :: ierr,jtot,k3671 3672 if(.not.(llesread)) return3673 3674 ! Read profiles at full levels3675 IF(nlev_max.EQ.19) THEN3676 open (ilesfile,file='prof.inp.19',status='old',iostat=ierr)3677 print *,'On ouvre prof.inp.19'3678 ELSE3679 open (ilesfile,file='prof.inp.40',status='old',iostat=ierr)3680 print *,'On ouvre prof.inp.40'3681 ENDIF3682 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3683 read (ilesfile,*) kmax3684 do k=1,kmax3685 read (ilesfile,*) height(k) ,pprof(k), uprof(k), vprof(k), &3686 & thetaprof(k) ,tprof(k), qvprof(k),rvprof(k)3687 enddo3688 close(ilesfile)3689 3690 ! Vertical coordinates half levels for eta-coordinates (plev = alpha + beta * psurf)3691 IF(nlev_max.EQ.19) THEN3692 open (ifile,file='proh.inp.19',status='old',iostat=ierr)3693 print *,'On ouvre proh.inp.19'3694 if (ierr /= 0) stop 'ERROR:Proh.inp.19 does not exist'3695 ELSE3696 open (ifile,file='proh.inp.40',status='old',iostat=ierr)3697 print *,'On ouvre proh.inp.40'3698 if (ierr /= 0) stop 'ERROR:Proh.inp.40 does not exist'3699 ENDIF3700 read (ifile,*) kmax3701 do k=1,kmax3702 read (ifile,*) jtot,aprof(k),bprof(k)3703 enddo3704 close(ifile)3705 3706 return3707 end3708 3709 !=====================================================================3710 subroutine read_fire(fich_fire,nlevel,ntime &3711 & ,zz,thl,qt,u,v,tke &3712 & ,ug,vg,wls,dqtdx,dqtdy,dqtdt,thl_rad)3713 3714 !program reading forcings of the FIRE case study3715 3716 3717 implicit none3718 3719 #include "netcdf.inc"3720 3721 integer ntime,nlevel3722 character*80 :: fich_fire3723 real*8 zz(nlevel)3724 3725 real*8 thl(nlevel)3726 real*8 qt(nlevel),u(nlevel)3727 real*8 v(nlevel),tke(nlevel)3728 real*8 ug(nlevel,ntime),vg(nlevel,ntime),wls(nlevel,ntime)3729 real*8 dqtdx(nlevel,ntime),dqtdy(nlevel,ntime)3730 real*8 dqtdt(nlevel,ntime),thl_rad(nlevel,ntime)3731 3732 integer nid, ierr3733 integer nbvar3d3734 parameter(nbvar3d=30)3735 integer var3didin(nbvar3d)3736 3737 ierr = NF_OPEN(fich_fire,NF_NOWRITE,nid)3738 if (ierr.NE.NF_NOERR) then3739 write(*,*) 'ERROR: Pb opening forcings nc file '3740 write(*,*) NF_STRERROR(ierr)3741 stop ""3742 endif3743 3744 3745 ierr=NF_INQ_VARID(nid,"zz",var3didin(1))3746 if(ierr/=NF_NOERR) then3747 write(*,*) NF_STRERROR(ierr)3748 stop 'lev'3749 endif3750 3751 3752 ierr=NF_INQ_VARID(nid,"thetal",var3didin(2))3753 if(ierr/=NF_NOERR) then3754 write(*,*) NF_STRERROR(ierr)3755 stop 'temp'3756 endif3757 3758 ierr=NF_INQ_VARID(nid,"qt",var3didin(3))3759 if(ierr/=NF_NOERR) then3760 write(*,*) NF_STRERROR(ierr)3761 stop 'qv'3762 endif3763 3764 ierr=NF_INQ_VARID(nid,"u",var3didin(4))3765 if(ierr/=NF_NOERR) then3766 write(*,*) NF_STRERROR(ierr)3767 stop 'u'3768 endif3769 3770 ierr=NF_INQ_VARID(nid,"v",var3didin(5))3771 if(ierr/=NF_NOERR) then3772 write(*,*) NF_STRERROR(ierr)3773 stop 'v'3774 endif3775 3776 ierr=NF_INQ_VARID(nid,"tke",var3didin(6))3777 if(ierr/=NF_NOERR) then3778 write(*,*) NF_STRERROR(ierr)3779 stop 'tke'3780 endif3781 3782 ierr=NF_INQ_VARID(nid,"ugeo",var3didin(7))3783 if(ierr/=NF_NOERR) then3784 write(*,*) NF_STRERROR(ierr)3785 stop 'ug'3786 endif3787 3788 ierr=NF_INQ_VARID(nid,"vgeo",var3didin(8))3789 if(ierr/=NF_NOERR) then3790 write(*,*) NF_STRERROR(ierr)3791 stop 'vg'3792 endif3793 3794 ierr=NF_INQ_VARID(nid,"wls",var3didin(9))3795 if(ierr/=NF_NOERR) then3796 write(*,*) NF_STRERROR(ierr)3797 stop 'wls'3798 endif3799 3800 ierr=NF_INQ_VARID(nid,"dqtdx",var3didin(10))3801 if(ierr/=NF_NOERR) then3802 write(*,*) NF_STRERROR(ierr)3803 stop 'dqtdx'3804 endif3805 3806 ierr=NF_INQ_VARID(nid,"dqtdy",var3didin(11))3807 if(ierr/=NF_NOERR) then3808 write(*,*) NF_STRERROR(ierr)3809 stop 'dqtdy'3810 endif3811 3812 ierr=NF_INQ_VARID(nid,"dqtdt",var3didin(12))3813 if(ierr/=NF_NOERR) then3814 write(*,*) NF_STRERROR(ierr)3815 stop 'dqtdt'3816 endif3817 3818 ierr=NF_INQ_VARID(nid,"thl_rad",var3didin(13))3819 if(ierr/=NF_NOERR) then3820 write(*,*) NF_STRERROR(ierr)3821 stop 'thl_rad'3822 endif3823 !dimensions lecture3824 ! call catchaxis(nid,ntime,nlevel,time,z,ierr)3825 3826 #ifdef NC_DOUBLE3827 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)3828 #else3829 ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)3830 #endif3831 if(ierr/=NF_NOERR) then3832 write(*,*) NF_STRERROR(ierr)3833 stop "getvarup"3834 endif3835 ! write(*,*)'lecture z ok',zz3836 3837 #ifdef NC_DOUBLE3838 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),thl)3839 #else3840 ierr = NF_GET_VAR_REAL(nid,var3didin(2),thl)3841 #endif3842 if(ierr/=NF_NOERR) then3843 write(*,*) NF_STRERROR(ierr)3844 stop "getvarup"3845 endif3846 ! write(*,*)'lecture thl ok',thl3847 3848 #ifdef NC_DOUBLE3849 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),qt)3850 #else3851 ierr = NF_GET_VAR_REAL(nid,var3didin(3),qt)3852 #endif3853 if(ierr/=NF_NOERR) then3854 write(*,*) NF_STRERROR(ierr)3855 stop "getvarup"3856 endif3857 ! write(*,*)'lecture qt ok',qt3858 3859 #ifdef NC_DOUBLE3860 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),u)3861 #else3862 ierr = NF_GET_VAR_REAL(nid,var3didin(4),u)3863 #endif3864 if(ierr/=NF_NOERR) then3865 write(*,*) NF_STRERROR(ierr)3866 stop "getvarup"3867 endif3868 ! write(*,*)'lecture u ok',u3869 3870 #ifdef NC_DOUBLE3871 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),v)3872 #else3873 ierr = NF_GET_VAR_REAL(nid,var3didin(5),v)3874 #endif3875 if(ierr/=NF_NOERR) then3876 write(*,*) NF_STRERROR(ierr)3877 stop "getvarup"3878 endif3879 ! write(*,*)'lecture v ok',v3880 3881 #ifdef NC_DOUBLE3882 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tke)3883 #else3884 ierr = NF_GET_VAR_REAL(nid,var3didin(6),tke)3885 #endif3886 if(ierr/=NF_NOERR) then3887 write(*,*) NF_STRERROR(ierr)3888 stop "getvarup"3889 endif3890 ! write(*,*)'lecture tke ok',tke3891 3892 #ifdef NC_DOUBLE3893 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ug)3894 #else3895 ierr = NF_GET_VAR_REAL(nid,var3didin(7),ug)3896 #endif3897 if(ierr/=NF_NOERR) then3898 write(*,*) NF_STRERROR(ierr)3899 stop "getvarup"3900 endif3901 ! write(*,*)'lecture ug ok',ug3902 3903 #ifdef NC_DOUBLE3904 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),vg)3905 #else3906 ierr = NF_GET_VAR_REAL(nid,var3didin(8),vg)3907 #endif3908 if(ierr/=NF_NOERR) then3909 write(*,*) NF_STRERROR(ierr)3910 stop "getvarup"3911 endif3912 ! write(*,*)'lecture vg ok',vg3913 3914 #ifdef NC_DOUBLE3915 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),wls)3916 #else3917 ierr = NF_GET_VAR_REAL(nid,var3didin(9),wls)3918 #endif3919 if(ierr/=NF_NOERR) then3920 write(*,*) NF_STRERROR(ierr)3921 stop "getvarup"3922 endif3923 ! write(*,*)'lecture wls ok',wls3924 3925 #ifdef NC_DOUBLE3926 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),dqtdx)3927 #else3928 ierr = NF_GET_VAR_REAL(nid,var3didin(10),dqtdx)3929 #endif3930 if(ierr/=NF_NOERR) then3931 write(*,*) NF_STRERROR(ierr)3932 stop "getvarup"3933 endif3934 ! write(*,*)'lecture dqtdx ok',dqtdx3935 3936 #ifdef NC_DOUBLE3937 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),dqtdy)3938 #else3939 ierr = NF_GET_VAR_REAL(nid,var3didin(11),dqtdy)3940 #endif3941 if(ierr/=NF_NOERR) then3942 write(*,*) NF_STRERROR(ierr)3943 stop "getvarup"3944 endif3945 ! write(*,*)'lecture dqtdy ok',dqtdy3946 3947 #ifdef NC_DOUBLE3948 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),dqtdt)3949 #else3950 ierr = NF_GET_VAR_REAL(nid,var3didin(12),dqtdt)3951 #endif3952 if(ierr/=NF_NOERR) then3953 write(*,*) NF_STRERROR(ierr)3954 stop "getvarup"3955 endif3956 ! write(*,*)'lecture dqtdt ok',dqtdt3957 3958 #ifdef NC_DOUBLE3959 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),thl_rad)3960 #else3961 ierr = NF_GET_VAR_REAL(nid,var3didin(13),thl_rad)3962 #endif3963 if(ierr/=NF_NOERR) then3964 write(*,*) NF_STRERROR(ierr)3965 stop "getvarup"3966 endif3967 ! write(*,*)'lecture thl_rad ok',thl_rad3968 3969 return3970 end subroutine read_fire3971 !=====================================================================3972 subroutine read_dice(fich_dice,nlevel,ntime &3973 & ,zz,pres,t,qv,u,v,o3 &3974 & ,shf,lhf,lwup,swup,tg,ustar,psurf,ug,vg &3975 & ,hadvt,hadvq,hadvu,hadvv,w,omega)3976 3977 !program reading initial profils and forcings of the Dice case study3978 3979 3980 implicit none3981 3982 #include "netcdf.inc"3983 #include "YOMCST.h"3984 3985 integer ntime,nlevel3986 integer l,k3987 character*80 :: fich_dice3988 real*8 time(ntime)3989 real*8 zz(nlevel)3990 3991 real*8 th(nlevel),pres(nlevel),t(nlevel)3992 real*8 qv(nlevel),u(nlevel),v(nlevel),o3(nlevel)3993 real*8 shf(ntime),lhf(ntime),lwup(ntime),swup(ntime),tg(ntime)3994 real*8 ustar(ntime),psurf(ntime),ug(ntime),vg(ntime)3995 real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime),hadvu(nlevel,ntime)3996 real*8 hadvv(nlevel,ntime),w(nlevel,ntime),omega(nlevel,ntime)3997 real*8 pzero3998 3999 integer nid, ierr4000 integer nbvar3d4001 parameter(nbvar3d=30)4002 integer var3didin(nbvar3d)4003 4004 pzero=100000.4005 ierr = NF_OPEN(fich_dice,NF_NOWRITE,nid)4006 if (ierr.NE.NF_NOERR) then4007 write(*,*) 'ERROR: Pb opening forcings nc file '4008 write(*,*) NF_STRERROR(ierr)4009 stop ""4010 endif4011 4012 4013 ierr=NF_INQ_VARID(nid,"height",var3didin(1))4014 if(ierr/=NF_NOERR) then4015 write(*,*) NF_STRERROR(ierr)4016 stop 'height'4017 endif4018 4019 ierr=NF_INQ_VARID(nid,"pf",var3didin(11))4020 if(ierr/=NF_NOERR) then4021 write(*,*) NF_STRERROR(ierr)4022 stop 'pf'4023 endif4024 4025 ierr=NF_INQ_VARID(nid,"theta",var3didin(12))4026 if(ierr/=NF_NOERR) then4027 write(*,*) NF_STRERROR(ierr)4028 stop 'theta'4029 endif4030 4031 ierr=NF_INQ_VARID(nid,"qv",var3didin(13))4032 if(ierr/=NF_NOERR) then4033 write(*,*) NF_STRERROR(ierr)4034 stop 'qv'4035 endif4036 4037 ierr=NF_INQ_VARID(nid,"u",var3didin(14))4038 if(ierr/=NF_NOERR) then4039 write(*,*) NF_STRERROR(ierr)4040 stop 'u'4041 endif4042 4043 ierr=NF_INQ_VARID(nid,"v",var3didin(15))4044 if(ierr/=NF_NOERR) then4045 write(*,*) NF_STRERROR(ierr)4046 stop 'v'4047 endif4048 4049 ierr=NF_INQ_VARID(nid,"o3mmr",var3didin(16))4050 if(ierr/=NF_NOERR) then4051 write(*,*) NF_STRERROR(ierr)4052 stop 'o3'4053 endif4054 4055 ierr=NF_INQ_VARID(nid,"shf",var3didin(2))4056 if(ierr/=NF_NOERR) then4057 write(*,*) NF_STRERROR(ierr)4058 stop 'shf'4059 endif4060 4061 ierr=NF_INQ_VARID(nid,"lhf",var3didin(3))4062 if(ierr/=NF_NOERR) then4063 write(*,*) NF_STRERROR(ierr)4064 stop 'lhf'4065 endif4066 4067 ierr=NF_INQ_VARID(nid,"lwup",var3didin(4))4068 if(ierr/=NF_NOERR) then4069 write(*,*) NF_STRERROR(ierr)4070 stop 'lwup'4071 endif4072 4073 ierr=NF_INQ_VARID(nid,"swup",var3didin(5))4074 if(ierr/=NF_NOERR) then4075 write(*,*) NF_STRERROR(ierr)4076 stop 'dqtdx'4077 endif4078 4079 ierr=NF_INQ_VARID(nid,"Tg",var3didin(6))4080 if(ierr/=NF_NOERR) then4081 write(*,*) NF_STRERROR(ierr)4082 stop 'Tg'4083 endif4084 4085 ierr=NF_INQ_VARID(nid,"ustar",var3didin(7))4086 if(ierr/=NF_NOERR) then4087 write(*,*) NF_STRERROR(ierr)4088 stop 'ustar'4089 endif4090 4091 ierr=NF_INQ_VARID(nid,"psurf",var3didin(8))4092 if(ierr/=NF_NOERR) then4093 write(*,*) NF_STRERROR(ierr)4094 stop 'psurf'4095 endif4096 4097 ierr=NF_INQ_VARID(nid,"Ug",var3didin(9))4098 if(ierr/=NF_NOERR) then4099 write(*,*) NF_STRERROR(ierr)4100 stop 'Ug'4101 endif4102 4103 ierr=NF_INQ_VARID(nid,"Vg",var3didin(10))4104 if(ierr/=NF_NOERR) then4105 write(*,*) NF_STRERROR(ierr)4106 stop 'Vg'4107 endif4108 4109 ierr=NF_INQ_VARID(nid,"hadvT",var3didin(17))4110 if(ierr/=NF_NOERR) then4111 write(*,*) NF_STRERROR(ierr)4112 stop 'hadvT'4113 endif4114 4115 ierr=NF_INQ_VARID(nid,"hadvq",var3didin(18))4116 if(ierr/=NF_NOERR) then4117 write(*,*) NF_STRERROR(ierr)4118 stop 'hadvq'4119 endif4120 4121 ierr=NF_INQ_VARID(nid,"hadvu",var3didin(19))4122 if(ierr/=NF_NOERR) then4123 write(*,*) NF_STRERROR(ierr)4124 stop 'hadvu'4125 endif4126 4127 ierr=NF_INQ_VARID(nid,"hadvv",var3didin(20))4128 if(ierr/=NF_NOERR) then4129 write(*,*) NF_STRERROR(ierr)4130 stop 'hadvv'4131 endif4132 4133 ierr=NF_INQ_VARID(nid,"w",var3didin(21))4134 if(ierr/=NF_NOERR) then4135 write(*,*) NF_STRERROR(ierr)4136 stop 'w'4137 endif4138 4139 ierr=NF_INQ_VARID(nid,"omega",var3didin(22))4140 if(ierr/=NF_NOERR) then4141 write(*,*) NF_STRERROR(ierr)4142 stop 'omega'4143 endif4144 !dimensions lecture4145 ! call catchaxis(nid,ntime,nlevel,time,z,ierr)4146 4147 #ifdef NC_DOUBLE4148 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)4149 #else4150 ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)4151 #endif4152 if(ierr/=NF_NOERR) then4153 write(*,*) NF_STRERROR(ierr)4154 stop "getvarup"4155 endif4156 ! write(*,*)'lecture zz ok',zz4157 4158 #ifdef NC_DOUBLE4159 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),pres)4160 #else4161 ierr = NF_GET_VAR_REAL(nid,var3didin(11),pres)4162 #endif4163 if(ierr/=NF_NOERR) then4164 write(*,*) NF_STRERROR(ierr)4165 stop "getvarup"4166 endif4167 ! write(*,*)'lecture pres ok',pres4168 4169 #ifdef NC_DOUBLE4170 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),th)4171 #else4172 ierr = NF_GET_VAR_REAL(nid,var3didin(12),th)4173 #endif4174 if(ierr/=NF_NOERR) then4175 write(*,*) NF_STRERROR(ierr)4176 stop "getvarup"4177 endif4178 ! write(*,*)'lecture th ok',th4179 do k=1,nlevel4180 t(k)=th(k)*(pres(k)/pzero)**rkappa4181 enddo4182 4183 #ifdef NC_DOUBLE4184 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),qv)4185 #else4186 ierr = NF_GET_VAR_REAL(nid,var3didin(13),qv)4187 #endif4188 if(ierr/=NF_NOERR) then4189 write(*,*) NF_STRERROR(ierr)4190 stop "getvarup"4191 endif4192 ! write(*,*)'lecture qv ok',qv4193 4194 #ifdef NC_DOUBLE4195 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),u)4196 #else4197 ierr = NF_GET_VAR_REAL(nid,var3didin(14),u)4198 #endif4199 if(ierr/=NF_NOERR) then4200 write(*,*) NF_STRERROR(ierr)4201 stop "getvarup"4202 endif4203 ! write(*,*)'lecture u ok',u4204 4205 #ifdef NC_DOUBLE4206 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),v)4207 #else4208 ierr = NF_GET_VAR_REAL(nid,var3didin(15),v)4209 #endif4210 if(ierr/=NF_NOERR) then4211 write(*,*) NF_STRERROR(ierr)4212 stop "getvarup"4213 endif4214 ! write(*,*)'lecture v ok',v4215 4216 #ifdef NC_DOUBLE4217 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),o3)4218 #else4219 ierr = NF_GET_VAR_REAL(nid,var3didin(16),o3)4220 #endif4221 if(ierr/=NF_NOERR) then4222 write(*,*) NF_STRERROR(ierr)4223 stop "getvarup"4224 endif4225 ! write(*,*)'lecture o3 ok',o34226 4227 #ifdef NC_DOUBLE4228 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),shf)4229 #else4230 ierr = NF_GET_VAR_REAL(nid,var3didin(2),shf)4231 #endif4232 if(ierr/=NF_NOERR) then4233 write(*,*) NF_STRERROR(ierr)4234 stop "getvarup"4235 endif4236 ! write(*,*)'lecture shf ok',shf4237 4238 #ifdef NC_DOUBLE4239 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),lhf)4240 #else4241 ierr = NF_GET_VAR_REAL(nid,var3didin(3),lhf)4242 #endif4243 if(ierr/=NF_NOERR) then4244 write(*,*) NF_STRERROR(ierr)4245 stop "getvarup"4246 endif4247 ! write(*,*)'lecture lhf ok',lhf4248 4249 #ifdef NC_DOUBLE4250 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),lwup)4251 #else4252 ierr = NF_GET_VAR_REAL(nid,var3didin(4),lwup)4253 #endif4254 if(ierr/=NF_NOERR) then4255 write(*,*) NF_STRERROR(ierr)4256 stop "getvarup"4257 endif4258 ! write(*,*)'lecture lwup ok',lwup4259 4260 #ifdef NC_DOUBLE4261 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),swup)4262 #else4263 ierr = NF_GET_VAR_REAL(nid,var3didin(5),swup)4264 #endif4265 if(ierr/=NF_NOERR) then4266 write(*,*) NF_STRERROR(ierr)4267 stop "getvarup"4268 endif4269 ! write(*,*)'lecture swup ok',swup4270 4271 #ifdef NC_DOUBLE4272 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tg)4273 #else4274 ierr = NF_GET_VAR_REAL(nid,var3didin(6),tg)4275 #endif4276 if(ierr/=NF_NOERR) then4277 write(*,*) NF_STRERROR(ierr)4278 stop "getvarup"4279 endif4280 ! write(*,*)'lecture tg ok',tg4281 4282 #ifdef NC_DOUBLE4283 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ustar)4284 #else4285 ierr = NF_GET_VAR_REAL(nid,var3didin(7),ustar)4286 #endif4287 if(ierr/=NF_NOERR) then4288 write(*,*) NF_STRERROR(ierr)4289 stop "getvarup"4290 endif4291 ! write(*,*)'lecture ustar ok',ustar4292 4293 #ifdef NC_DOUBLE4294 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),psurf)4295 #else4296 ierr = NF_GET_VAR_REAL(nid,var3didin(8),psurf)4297 #endif4298 if(ierr/=NF_NOERR) then4299 write(*,*) NF_STRERROR(ierr)4300 stop "getvarup"4301 endif4302 ! write(*,*)'lecture psurf ok',psurf4303 4304 #ifdef NC_DOUBLE4305 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),ug)4306 #else4307 ierr = NF_GET_VAR_REAL(nid,var3didin(9),ug)4308 #endif4309 if(ierr/=NF_NOERR) then4310 write(*,*) NF_STRERROR(ierr)4311 stop "getvarup"4312 endif4313 ! write(*,*)'lecture ug ok',ug4314 4315 #ifdef NC_DOUBLE4316 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),vg)4317 #else4318 ierr = NF_GET_VAR_REAL(nid,var3didin(10),vg)4319 #endif4320 if(ierr/=NF_NOERR) then4321 write(*,*) NF_STRERROR(ierr)4322 stop "getvarup"4323 endif4324 ! write(*,*)'lecture vg ok',vg4325 4326 #ifdef NC_DOUBLE4327 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hadvt)4328 #else4329 ierr = NF_GET_VAR_REAL(nid,var3didin(17),hadvt)4330 #endif4331 if(ierr/=NF_NOERR) then4332 write(*,*) NF_STRERROR(ierr)4333 stop "getvarup"4334 endif4335 ! write(*,*)'lecture hadvt ok',hadvt4336 4337 #ifdef NC_DOUBLE4338 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),hadvq)4339 #else4340 ierr = NF_GET_VAR_REAL(nid,var3didin(18),hadvq)4341 #endif4342 if(ierr/=NF_NOERR) then4343 write(*,*) NF_STRERROR(ierr)4344 stop "getvarup"4345 endif4346 ! write(*,*)'lecture hadvq ok',hadvq4347 4348 #ifdef NC_DOUBLE4349 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),hadvu)4350 #else4351 ierr = NF_GET_VAR_REAL(nid,var3didin(19),hadvu)4352 #endif4353 if(ierr/=NF_NOERR) then4354 write(*,*) NF_STRERROR(ierr)4355 stop "getvarup"4356 endif4357 ! write(*,*)'lecture hadvu ok',hadvu4358 4359 #ifdef NC_DOUBLE4360 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),hadvv)4361 #else4362 ierr = NF_GET_VAR_REAL(nid,var3didin(20),hadvv)4363 #endif4364 if(ierr/=NF_NOERR) then4365 write(*,*) NF_STRERROR(ierr)4366 stop "getvarup"4367 endif4368 ! write(*,*)'lecture hadvv ok',hadvv4369 4370 #ifdef NC_DOUBLE4371 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),w)4372 #else4373 ierr = NF_GET_VAR_REAL(nid,var3didin(21),w)4374 #endif4375 if(ierr/=NF_NOERR) then4376 write(*,*) NF_STRERROR(ierr)4377 stop "getvarup"4378 endif4379 ! write(*,*)'lecture w ok',w4380 4381 #ifdef NC_DOUBLE4382 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),omega)4383 #else4384 ierr = NF_GET_VAR_REAL(nid,var3didin(22),omega)4385 #endif4386 if(ierr/=NF_NOERR) then4387 write(*,*) NF_STRERROR(ierr)4388 stop "getvarup"4389 endif4390 ! write(*,*)'lecture omega ok',omega4391 4392 return4393 end subroutine read_dice4394 !=====================================================================4395 subroutine read_gabls4(fich_gabls4,nlevel,ntime,nsol &4396 & ,zz,depth_sn,ug,vg,pf,th,t,qv,u,v,hadvt,hadvq,tg,tsnow,snow_dens)4397 4398 !program reading initial profils and forcings of the Gabls4 case study4399 4400 4401 implicit none4402 4403 #include "netcdf.inc"4404 4405 integer ntime,nlevel,nsol4406 integer l,k4407 character*80 :: fich_gabls44408 real*8 time(ntime)4409 4410 ! ATTENTION: visiblement quand on lit gabls4_driver.nc on recupere les donnees4411 ! dans un ordre inverse par rapport a la convention LMDZ4412 ! ==> il faut tout inverser (MPL 20141024)4413 ! les variables indexees "_i" sont celles qui sont lues dans gabls4_driver.nc4414 real*8 zz_i(nlevel),th_i(nlevel),pf_i(nlevel),t_i(nlevel)4415 real*8 qv_i(nlevel),u_i(nlevel),v_i(nlevel),ug_i(nlevel,ntime),vg_i(nlevel,ntime)4416 real*8 hadvt_i(nlevel,ntime),hadvq_i(nlevel,ntime)4417 4418 real*8 zz(nlevel),th(nlevel),pf(nlevel),t(nlevel)4419 real*8 qv(nlevel),u(nlevel),v(nlevel),ug(nlevel,ntime),vg(nlevel,ntime)4420 real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime)4421 4422 real*8 depth_sn(nsol),tsnow(nsol),snow_dens(nsol)4423 real*8 tg(ntime)4424 integer nid, ierr4425 integer nbvar3d4426 parameter(nbvar3d=30)4427 integer var3didin(nbvar3d)4428 4429 ierr = NF_OPEN(fich_gabls4,NF_NOWRITE,nid)4430 if (ierr.NE.NF_NOERR) then4431 write(*,*) 'ERROR: Pb opening forcings nc file '4432 write(*,*) NF_STRERROR(ierr)4433 stop ""4434 endif4435 4436 4437 ierr=NF_INQ_VARID(nid,"height",var3didin(1))4438 if(ierr/=NF_NOERR) then4439 write(*,*) NF_STRERROR(ierr)4440 stop 'height'4441 endif4442 4443 ierr=NF_INQ_VARID(nid,"depth_sn",var3didin(2))4444 if(ierr/=NF_NOERR) then4445 write(*,*) NF_STRERROR(ierr)4446 stop 'depth_sn'4447 endif4448 4449 ierr=NF_INQ_VARID(nid,"Ug",var3didin(3))4450 if(ierr/=NF_NOERR) then4451 write(*,*) NF_STRERROR(ierr)4452 stop 'Ug'4453 endif4454 4455 ierr=NF_INQ_VARID(nid,"Vg",var3didin(4))4456 if(ierr/=NF_NOERR) then4457 write(*,*) NF_STRERROR(ierr)4458 stop 'Vg'4459 endif4460 ierr=NF_INQ_VARID(nid,"pf",var3didin(5))4461 if(ierr/=NF_NOERR) then4462 write(*,*) NF_STRERROR(ierr)4463 stop 'pf'4464 endif4465 4466 ierr=NF_INQ_VARID(nid,"theta",var3didin(6))4467 if(ierr/=NF_NOERR) then4468 write(*,*) NF_STRERROR(ierr)4469 stop 'theta'4470 endif4471 4472 ierr=NF_INQ_VARID(nid,"tempe",var3didin(7))4473 if(ierr/=NF_NOERR) then4474 write(*,*) NF_STRERROR(ierr)4475 stop 'tempe'4476 endif4477 4478 ierr=NF_INQ_VARID(nid,"qv",var3didin(8))4479 if(ierr/=NF_NOERR) then4480 write(*,*) NF_STRERROR(ierr)4481 stop 'qv'4482 endif4483 4484 ierr=NF_INQ_VARID(nid,"u",var3didin(9))4485 if(ierr/=NF_NOERR) then4486 write(*,*) NF_STRERROR(ierr)4487 stop 'u'4488 endif4489 4490 ierr=NF_INQ_VARID(nid,"v",var3didin(10))4491 if(ierr/=NF_NOERR) then4492 write(*,*) NF_STRERROR(ierr)4493 stop 'v'4494 endif4495 4496 ierr=NF_INQ_VARID(nid,"hadvT",var3didin(11))4497 if(ierr/=NF_NOERR) then4498 write(*,*) NF_STRERROR(ierr)4499 stop 'hadvt'4500 endif4501 4502 ierr=NF_INQ_VARID(nid,"hadvQ",var3didin(12))4503 if(ierr/=NF_NOERR) then4504 write(*,*) NF_STRERROR(ierr)4505 stop 'hadvq'4506 endif4507 4508 ierr=NF_INQ_VARID(nid,"Tsnow",var3didin(14))4509 if(ierr/=NF_NOERR) then4510 write(*,*) NF_STRERROR(ierr)4511 stop 'tsnow'4512 endif4513 4514 ierr=NF_INQ_VARID(nid,"snow_density",var3didin(15))4515 if(ierr/=NF_NOERR) then4516 write(*,*) NF_STRERROR(ierr)4517 stop 'snow_density'4518 endif4519 4520 ierr=NF_INQ_VARID(nid,"Tg",var3didin(16))4521 if(ierr/=NF_NOERR) then4522 write(*,*) NF_STRERROR(ierr)4523 stop 'Tg'4524 endif4525 4526 4527 !dimensions lecture4528 ! call catchaxis(nid,ntime,nlevel,time,z,ierr)4529 4530 #ifdef NC_DOUBLE4531 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz_i)4532 #else4533 ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz_i)4534 #endif4535 if(ierr/=NF_NOERR) then4536 write(*,*) NF_STRERROR(ierr)4537 stop "getvarup"4538 endif4539 4540 #ifdef NC_DOUBLE4541 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),depth_sn)4542 #else4543 ierr = NF_GET_VAR_REAL(nid,var3didin(2),depth_sn)4544 #endif4545 if(ierr/=NF_NOERR) then4546 write(*,*) NF_STRERROR(ierr)4547 stop "getvarup"4548 endif4549 4550 #ifdef NC_DOUBLE4551 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),ug_i)4552 #else4553 ierr = NF_GET_VAR_REAL(nid,var3didin(3),ug_i)4554 #endif4555 if(ierr/=NF_NOERR) then4556 write(*,*) NF_STRERROR(ierr)4557 stop "getvarup"4558 endif4559 4560 #ifdef NC_DOUBLE4561 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),vg_i)4562 #else4563 ierr = NF_GET_VAR_REAL(nid,var3didin(4),vg_i)4564 #endif4565 if(ierr/=NF_NOERR) then4566 write(*,*) NF_STRERROR(ierr)4567 stop "getvarup"4568 endif4569 4570 #ifdef NC_DOUBLE4571 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),pf_i)4572 #else4573 ierr = NF_GET_VAR_REAL(nid,var3didin(5),pf_i)4574 #endif4575 if(ierr/=NF_NOERR) then4576 write(*,*) NF_STRERROR(ierr)4577 stop "getvarup"4578 endif4579 4580 #ifdef NC_DOUBLE4581 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),th_i)4582 #else4583 ierr = NF_GET_VAR_REAL(nid,var3didin(6),th_i)4584 #endif4585 if(ierr/=NF_NOERR) then4586 write(*,*) NF_STRERROR(ierr)4587 stop "getvarup"4588 endif4589 4590 #ifdef NC_DOUBLE4591 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),t_i)4592 #else4593 ierr = NF_GET_VAR_REAL(nid,var3didin(7),t_i)4594 #endif4595 if(ierr/=NF_NOERR) then4596 write(*,*) NF_STRERROR(ierr)4597 stop "getvarup"4598 endif4599 4600 #ifdef NC_DOUBLE4601 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),qv_i)4602 #else4603 ierr = NF_GET_VAR_REAL(nid,var3didin(8),qv_i)4604 #endif4605 if(ierr/=NF_NOERR) then4606 write(*,*) NF_STRERROR(ierr)4607 stop "getvarup"4608 endif4609 4610 #ifdef NC_DOUBLE4611 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),u_i)4612 #else4613 ierr = NF_GET_VAR_REAL(nid,var3didin(9),u_i)4614 #endif4615 if(ierr/=NF_NOERR) then4616 write(*,*) NF_STRERROR(ierr)4617 stop "getvarup"4618 endif4619 4620 #ifdef NC_DOUBLE4621 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),v_i)4622 #else4623 ierr = NF_GET_VAR_REAL(nid,var3didin(10),v_i)4624 #endif4625 if(ierr/=NF_NOERR) then4626 write(*,*) NF_STRERROR(ierr)4627 stop "getvarup"4628 endif4629 4630 #ifdef NC_DOUBLE4631 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),hadvt_i)4632 #else4633 ierr = NF_GET_VAR_REAL(nid,var3didin(11),hadvt_i)4634 #endif4635 if(ierr/=NF_NOERR) then4636 write(*,*) NF_STRERROR(ierr)4637 stop "getvarup"4638 endif4639 4640 #ifdef NC_DOUBLE4641 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),hadvq_i)4642 #else4643 ierr = NF_GET_VAR_REAL(nid,var3didin(12),hadvq_i)4644 #endif4645 if(ierr/=NF_NOERR) then4646 write(*,*) NF_STRERROR(ierr)4647 stop "getvarup"4648 endif4649 4650 #ifdef NC_DOUBLE4651 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),tsnow)4652 #else4653 ierr = NF_GET_VAR_REAL(nid,var3didin(14),tsnow)4654 #endif4655 if(ierr/=NF_NOERR) then4656 write(*,*) NF_STRERROR(ierr)4657 stop "getvarup"4658 endif4659 4660 #ifdef NC_DOUBLE4661 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),snow_dens)4662 #else4663 ierr = NF_GET_VAR_REAL(nid,var3didin(15),snow_dens)4664 #endif4665 if(ierr/=NF_NOERR) then4666 write(*,*) NF_STRERROR(ierr)4667 stop "getvarup"4668 endif4669 4670 #ifdef NC_DOUBLE4671 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),tg)4672 #else4673 ierr = NF_GET_VAR_REAL(nid,var3didin(16),tg)4674 #endif4675 if(ierr/=NF_NOERR) then4676 write(*,*) NF_STRERROR(ierr)4677 stop "getvarup"4678 endif4679 4680 ! On remet les variables lues dans le bon ordre des niveaux (MPL 20141024)4681 do k=1,nlevel4682 zz(k)=zz_i(nlevel+1-k)4683 ug(k,:)=ug_i(nlevel+1-k,:)4684 vg(k,:)=vg_i(nlevel+1-k,:)4685 pf(k)=pf_i(nlevel+1-k)4686 print *,'pf=',pf(k)4687 th(k)=th_i(nlevel+1-k)4688 t(k)=t_i(nlevel+1-k)4689 qv(k)=qv_i(nlevel+1-k)4690 u(k)=u_i(nlevel+1-k)4691 v(k)=v_i(nlevel+1-k)4692 hadvt(k,:)=hadvt_i(nlevel+1-k,:)4693 hadvq(k,:)=hadvq_i(nlevel+1-k,:)4694 enddo4695 return4696 end subroutine read_gabls44697 !=====================================================================4698 4699 ! Reads CIRC input files4700 4701 SUBROUTINE read_circ(nlev_circ,cf,lwp,iwp,reliq,reice,t,z,p,pm,h2o,o3,sza)4702 4703 parameter (ncm_1=49180)4704 #include "YOMCST.h"4705 4706 real albsfc(ncm_1), albsfc_w(ncm_1)4707 real cf(nlev_circ), icefra(nlev_circ), deice(nlev_circ), &4708 reliq(nlev_circ), reice(nlev_circ), lwp(nlev_circ), iwp(nlev_circ)4709 real t(nlev_circ+1), z(nlev_circ+1), dz(nlev_circ), p(nlev_circ+1)4710 real aer_beta(nlev_circ), waer(nlev_circ), gaer(nlev_circ)4711 real pm(nlev_circ), tm(nlev_circ), h2o(nlev_circ), o3(nlev_circ)4712 real co2(nlev_circ), n2o(nlev_circ), co(nlev_circ), ch4(nlev_circ), &4713 o2(nlev_circ), ccl4(nlev_circ), f11(nlev_circ), f12(nlev_circ)4714 ! za= zenital angle4715 ! sza= cosinus angle zenital4716 real wavn(ncm_1), ssf(ncm_1),za,sza4717 integer nlev4718 4719 4720 ! Open the files4721 4722 open (11, file='Tsfc_sza_nlev_case.txt', status='old')4723 open (12, file='level_input_case.txt', status='old')4724 open (13, file='layer_input_case.txt', status='old')4725 open (14, file='aerosol_input_case.txt', status='old')4726 open (15, file='cloud_input_case.txt', status='old')4727 open (16, file='sfcalbedo_input_case.txt', status='old')4728 4729 ! Read scalar information4730 do iskip=1,54731 read (11, *)4732 enddo4733 read (11, '(i8)') nlev4734 read (11, '(f10.2)') tsfc4735 read (11, '(f10.2)') za4736 read (11, '(f10.4)') sw_dn_toa4737 sza=cos(za/180.*RPI)4738 print *,'nlev,tsfc,sza,sw_dn_toa,RPI',nlev,tsfc,sza,sw_dn_toa,RPI4739 close(11)4740 4741 ! Read level information4742 read (12, *)4743 do il=1,nlev4744 read (12, 302) ilev, z(il), p(il), t(il)4745 z(il)=z(il)*1000. ! z donne en km4746 p(il)=p(il)*100. ! p donne en mb4747 enddo4748 302 format (i8, f8.3, 2f9.2)4749 close(12)4750 4751 ! Read layer information (midpoint values)4752 do iskip=1,34753 read (13, *)4754 enddo4755 do il=1,nlev-14756 read (13, 303) ilev,pm(il),tm(il),h2o(il),co2(il),o3(il), &4757 n2o(il),co(il),ch4(il),o2(il),ccl4(il), &4758 f11(il),f12(il)4759 pm(il)=pm(il)*100.4760 enddo4761 303 format (i8, 2f9.2, 10(2x,e13.7))4762 close(13)4763 4764 ! Read aerosol layer information4765 do iskip=1,34766 read (14, *)4767 enddo4768 read (14, '(f10.2)') aer_alpha4769 read (14, *)4770 read (14, *)4771 do il=1,nlev-14772 read (14, 304) ilev, aer_beta(il), waer(il), gaer(il)4773 enddo4774 304 format (i8, f9.5, 2f8.3)4775 close(14)4776 4777 ! Read cloud information4778 do iskip=1,34779 read (15, *)4780 enddo4781 do il=1,nlev-14782 read (15, 305) ilev, cf(il), lwp(il), iwp(il), reliq(il), reice(il)4783 lwp(il)=lwp(il)/1000. ! lwp donne en g/kg4784 iwp(il)=iwp(il)/1000. ! iwp donne en g/kg4785 reliq(il)=reliq(il)/1000000. ! reliq donne en microns4786 reice(il)=reice(il)/1000000. ! reice donne en microns4787 enddo4788 305 format (i8, f8.3, 4f9.2)4789 close(15)4790 4791 ! Read surface albedo (weighted & unweighted) and spectral solar irradiance4792 do iskip=1,64793 read (16, *)4794 enddo4795 do icm_1=1,ncm_14796 read (16, 306) wavn(icm_1), albsfc(icm_1), albsfc_w(icm_1), ssf(icm_1)4797 enddo4798 306 format(f10.1, 2f12.5, f14.8)4799 close(16)4800 4801 return4802 end subroutine read_circ4803 !=====================================================================4804 ! Reads RTMIP input files4805 4806 SUBROUTINE read_rtmip(nlev_rtmip,play,plev,t,h2o,o3)4807 4808 #include "YOMCST.h"4809 4810 real t(nlev_rtmip), pt(nlev_rtmip),pb(nlev_rtmip),h2o(nlev_rtmip), o3(nlev_rtmip)4811 real temp(nlev_rtmip), play(nlev_rtmip),ovap(nlev_rtmip), oz(nlev_rtmip),plev(nlev_rtmip+1)4812 integer nlev4813 4814 4815 ! Open the files4816 4817 open (11, file='low_resolution_profile.txt', status='old')4818 4819 ! Read level information4820 read (11, *)4821 do il=1,nlev_rtmip4822 read (11, 302) pt(il), pb(il), t(il),h2o(il),o3(il)4823 enddo4824 do il=1,nlev_rtmip4825 play(il)=pt(nlev_rtmip-il+1)*100. ! p donne en mb4826 temp(il)=t(nlev_rtmip-il+1)4827 ovap(il)=h2o(nlev_rtmip-il+1)4828 oz(il)=o3(nlev_rtmip-il+1)4829 enddo4830 do il=1,394831 plev(il)=play(il)+(play(il+1)-play(il))/2.4832 print *,'il p t ovap oz=',il,plev(il),temp(il),ovap(il),oz(il)4833 enddo4834 plev(41)=101300.4835 302 format (e16.10,3x,e16.10,3x,e16.10,3x,e12.6,3x,e12.6)4836 close(12)4837 4838 return4839 end subroutine read_rtmip4840 !=====================================================================4841 1462 4842 1463 ! Subroutines for nudging … … 5127 1748 real frac,frac1,frac2,fact 5128 1749 5129 do l = 1, llm5130 print *,'debut interp2, play=',l,play(l)5131 enddo1750 ! do l = 1, llm 1751 ! print *,'debut interp2, play=',l,play(l) 1752 ! enddo 5132 1753 ! do l = 1, nlev_cas 5133 1754 ! print *,'debut interp2, plev_prof_cas=',l,play(l),plev_prof_cas(l) … … 5139 1760 5140 1761 mxcalc=l 5141 print *,'debut interp2, mxcalc=',mxcalc1762 ! print *,'debut interp2, mxcalc=',mxcalc 5142 1763 k1=0 5143 1764 k2=0 -
LMDZ6/trunk/libf/phylmd/dyn1d/1D_interp_cases.h
r3537 r3541 1 ! 2 ! $Id$ 3 ! 4 !--------------------------------------------------------------------- 5 ! Forcing_LES case: constant dq_dyn 6 !--------------------------------------------------------------------- 7 if (forcing_LES) then 8 DO l = 1,llm 9 d_q_adv(l,1) = dq_dyn(l,1) 10 ENDDO 11 endif ! forcing_LES 12 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 13 !--------------------------------------------------------------------- 14 ! Interpolation forcing in time and onto model levels 15 !--------------------------------------------------------------------- 16 if (forcing_GCSSold) then 17 18 call get_uvd(it,timestep,fich_gcssold_ctl,fich_gcssold_dat, & 19 & ht_gcssold,hq_gcssold,hw_gcssold, & 20 & hu_gcssold,hv_gcssold, & 21 & hthturb_gcssold,hqturb_gcssold,Ts_gcssold, & 22 & imp_fcg_gcssold,ts_fcg_gcssold, & 23 & Tp_fcg_gcssold,Turb_fcg_gcssold) 24 if (prt_level.ge.1) then 25 print *,' get_uvd -> hqturb_gcssold ',it,hqturb_gcssold 26 endif 27 ! large-scale forcing : 28 !!! tsurf = ts_gcssold 29 do l = 1, llm 30 ! u(l) = hu_gcssold(l) ! on prescrit le vent 31 ! v(l) = hv_gcssold(l) ! on prescrit le vent 32 ! omega(l) = hw_gcssold(l) 33 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 34 ! omega2(l)=-rho(l)*omega(l) 35 omega(l) = hw_gcssold(l) 36 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 37 38 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 39 d_t_adv(l) = ht_gcssold(l) 40 d_q_adv(l,1) = hq_gcssold(l) 41 dt_cooling(l) = 0.0 42 enddo 43 44 endif ! forcing_GCSSold 45 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 46 !--------------------------------------------------------------------- 47 ! Interpolation Toga forcing 48 !--------------------------------------------------------------------- 49 if (forcing_toga) then 50 51 if (prt_level.ge.1) then 52 print*, & 53 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_toga=', & 54 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_toga 55 endif 56 57 ! time interpolation: 58 CALL interp_toga_time(daytime,day1,annee_ref & 59 & ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga & 60 & ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga & 61 & ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga & 62 & ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof & 63 & ,ht_prof,vt_prof,hq_prof,vq_prof) 64 65 if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d 66 67 ! vertical interpolation: 68 CALL interp_toga_vertical(play,nlev_toga,plev_prof & 69 & ,t_prof,q_prof,u_prof,v_prof,w_prof & 70 & ,ht_prof,vt_prof,hq_prof,vq_prof & 71 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 72 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 73 74 ! large-scale forcing : 75 tsurf = ts_prof 76 do l = 1, llm 77 u(l) = u_mod(l) ! sb: on prescrit le vent 78 v(l) = v_mod(l) ! sb: on prescrit le vent 79 ! omega(l) = w_prof(l) 80 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 81 ! omega2(l)=-rho(l)*omega(l) 82 omega(l) = w_mod(l) 83 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 84 85 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 86 d_t_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l)) 87 d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l)) 88 dt_cooling(l) = 0.0 89 enddo 90 91 endif ! forcing_toga 92 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 93 ! Interpolation DICE forcing 94 !--------------------------------------------------------------------- 95 if (forcing_dice) then 96 97 if (prt_level.ge.1) then 98 print*,'#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_dice=',& 99 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_dice 100 endif 101 102 ! time interpolation: 103 CALL interp_dice_time(daytime,day1,annee_ref & 104 & ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice & 105 & ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice & 106 & ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice & 107 & ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice & 108 & ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof & 109 & ,ustar_prof,psurf_prof,ug_profd,vg_profd & 110 & ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd & 111 & ,omega_profd) 112 ! do l = 1, llm 113 ! print *,'llm l omega_profd',llm,l,omega_profd(l) 114 ! enddo 115 116 if (type_ts_forcing.eq.1) ts_cur = tg_prof ! SST used in read_tsurf1d 117 118 ! vertical interpolation: 119 CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice & 120 & ,t_dice,qv_dice,u_dice,v_dice,o3_dice & 121 & ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd,omega_profd & 122 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 123 & ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc) 124 ! do l = 1, llm 125 ! print *,'llm l omega_mod',llm,l,omega_mod(l) 126 ! enddo 127 128 ! Les forcages DICE sont donnes /jour et non /seconde ! 129 ht_mod(:)=ht_mod(:)/86400. 130 hq_mod(:)=hq_mod(:)/86400. 131 hu_mod(:)=hu_mod(:)/86400. 132 hv_mod(:)=hv_mod(:)/86400. 133 134 !calcul de l'advection verticale a partir du omega (repris cas TWPICE, MPL 05082013) 135 !Calcul des gradients verticaux 136 !initialisation 137 d_t_z(:)=0. 138 d_q_z(:)=0. 139 d_u_z(:)=0. 140 d_v_z(:)=0. 141 DO l=2,llm-1 142 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 143 d_q_z(l)=(q(l+1,1)-q(l-1,1)) /(play(l+1)-play(l-1)) 144 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 145 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 146 ENDDO 147 d_t_z(1)=d_t_z(2) 148 d_q_z(1)=d_q_z(2) 149 ! d_u_z(1)=u(2)/(play(2)-psurf)/5. 150 ! d_v_z(1)=v(2)/(play(2)-psurf)/5. 151 d_u_z(1)=0. 152 d_v_z(1)=0. 153 d_t_z(llm)=d_t_z(llm-1) 154 d_q_z(llm)=d_q_z(llm-1) 155 d_u_z(llm)=d_u_z(llm-1) 156 d_v_z(llm)=d_v_z(llm-1) 157 158 !Calcul de l advection verticale: 159 ! utiliser omega (Pa/s) et non w (m/s) !! MP 20131108 160 d_t_dyn_z(:)=omega_mod(:)*d_t_z(:) 161 d_q_dyn_z(:)=omega_mod(:)*d_q_z(:) 162 d_u_dyn_z(:)=omega_mod(:)*d_u_z(:) 163 d_v_dyn_z(:)=omega_mod(:)*d_v_z(:) 164 165 ! large-scale forcing : 166 ! tsurf = tg_prof MPL 20130925 commente 167 psurf = psurf_prof 168 ! For this case, fluxes are imposed 169 fsens=-1*shf_prof 170 flat=-1*lhf_prof 171 ust=ustar_prof 172 tg=tg_prof 173 print *,'ust= ',ust 174 do l = 1, llm 175 ug(l)= ug_profd 176 vg(l)= vg_profd 177 ! omega(l) = w_prof(l) 178 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 179 ! omega2(l)=-rho(l)*omega(l) 180 ! omega(l) = w_mod(l)*(-rg*rho(l)) 181 omega(l) = omega_mod(l) 182 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 183 184 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 185 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l) 186 d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l) 187 d_u_adv(l) = hu_mod(l)-d_u_dyn_z(l) 188 d_v_adv(l) = hv_mod(l)-d_v_dyn_z(l) 189 dt_cooling(l) = 0.0 190 enddo 191 192 endif ! forcing_dice 193 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 194 ! Interpolation gabls4 forcing 195 !--------------------------------------------------------------------- 196 if (forcing_gabls4 ) then 197 198 if (prt_level.ge.1) then 199 print*,'#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_gabls4=',& 200 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_gabls4 201 endif 202 203 ! time interpolation: 204 CALL interp_gabls4_time(daytime,day1,annee_ref & 205 & ,year_ini_gabls4,day_ju_ini_gabls4,nt_gabls4,dt_gabls4,nlev_gabls4 & 206 & ,ug_gabls4,vg_gabls4,ht_gabls4,hq_gabls4,tg_gabls4 & 207 & ,ug_profg,vg_profg,ht_profg,hq_profg,tg_profg) 208 209 if (type_ts_forcing.eq.1) ts_cur = tg_prof ! SST used in read_tsurf1d 210 211 ! vertical interpolation: 212 ! on re-utilise le programme interp_dice_vertical: les transformations sur 213 ! plev_gabls4,th_gabls4,qv_gabls4,u_gabls4,v_gabls4 ne sont pas prises en compte. 214 ! seules celles sur ht_profg,hq_profg,ug_profg,vg_profg sont prises en compte. 215 216 CALL interp_dice_vertical(play,nlev_gabls4,nt_gabls4,plev_gabls4 & 217 ! & ,t_gabls4,qv_gabls4,u_gabls4,v_gabls4,poub & 218 & ,poub,poub,poub,poub,poub & 219 & ,ht_profg,hq_profg,ug_profg,vg_profg,poub,poub & 220 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 221 & ,ht_mod,hq_mod,ug_mod,vg_mod,w_mod,omega_mod,mxcalc) 222 223 do l = 1, llm 224 ug(l)= ug_mod(l) 225 vg(l)= vg_mod(l) 226 d_t_adv(l)=ht_mod(l) 227 d_q_adv(l,1)=hq_mod(l) 228 enddo 229 230 endif ! forcing_gabls4 231 !--------------------------------------------------------------------- 232 233 !--------------------------------------------------------------------- 234 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 235 !--------------------------------------------------------------------- 236 ! Interpolation forcing TWPice 237 !--------------------------------------------------------------------- 238 if (forcing_twpice) then 239 240 print*, & 241 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_twpi=', & 242 & daytime,day1,(daytime-day1)*86400., & 243 & (daytime-day1)*86400/dt_twpi 244 245 ! time interpolation: 246 CALL interp_toga_time(daytime,day1,annee_ref & 247 & ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi & 248 & ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi & 249 & ,ht_twpi,vt_twpi,hq_twpi,vq_twpi & 250 & ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp,u_proftwp & 251 & ,v_proftwp,w_proftwp & 252 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp) 253 254 ! vertical interpolation: 255 CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp & 256 & ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp & 257 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp & 258 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 259 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 260 261 262 !calcul de l'advection verticale a partir du omega 263 !Calcul des gradients verticaux 264 !initialisation 265 d_t_z(:)=0. 266 d_q_z(:)=0. 267 d_t_dyn_z(:)=0. 268 d_q_dyn_z(:)=0. 269 DO l=2,llm-1 270 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 271 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 272 ENDDO 273 d_t_z(1)=d_t_z(2) 274 d_q_z(1)=d_q_z(2) 275 d_t_z(llm)=d_t_z(llm-1) 276 d_q_z(llm)=d_q_z(llm-1) 277 278 !Calcul de l advection verticale 279 d_t_dyn_z(:)=w_mod(:)*d_t_z(:) 280 d_q_dyn_z(:)=w_mod(:)*d_q_z(:) 281 282 !wind nudging above 500m with a 2h time scale 283 do l=1,llm 284 if (nudge_wind) then 285 ! if (phi(l).gt.5000.) then 286 if (phi(l).gt.0.) then 287 u(l)=u(l)+timestep*(u_mod(l)-u(l))/(2.*3600.) 288 v(l)=v(l)+timestep*(v_mod(l)-v(l))/(2.*3600.) 289 endif 290 else 291 u(l) = u_mod(l) 292 v(l) = v_mod(l) 293 endif 294 enddo 295 296 !CR:nudging of q and theta with a 6h time scale above 15km 297 if (nudge_thermo) then 298 do l=1,llm 299 zz(l)=phi(l)/9.8 300 if ((zz(l).le.16000.).and.(zz(l).gt.15000.)) then 301 zfact=(zz(l)-15000.)/1000. 302 q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.)*zfact 303 temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.)*zfact 304 else if (zz(l).gt.16000.) then 305 q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.) 306 temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.) 307 endif 308 enddo 309 endif 310 311 do l = 1, llm 312 omega(l) = w_mod(l) 313 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 314 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 315 !calcul de l'advection totale 316 if (cptadvw) then 317 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l) 318 ! print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l) 319 d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l) 320 ! print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l) 321 else 322 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l)) 323 d_q_adv(l,1) = (hq_mod(l)+vq_mod(l)) 324 endif 325 dt_cooling(l) = 0.0 326 enddo 327 328 endif ! forcing_twpice 329 330 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 331 !--------------------------------------------------------------------- 332 ! Interpolation forcing AMMA 333 !--------------------------------------------------------------------- 334 335 if (forcing_amma) then 336 337 print*, & 338 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_amma=', & 339 & daytime,day1,(daytime-day1)*86400., & 340 & (daytime-day1)*86400/dt_amma 341 342 ! time interpolation using TOGA interpolation routine 343 CALL interp_amma_time(daytime,day1,annee_ref & 344 & ,year_ini_amma,day_ju_ini_amma,nt_amma,dt_amma,nlev_amma & 345 & ,vitw_amma,ht_amma,hq_amma,lat_amma,sens_amma & 346 & ,vitw_profamma,ht_profamma,hq_profamma,lat_profamma & 347 & ,sens_profamma) 348 349 print*,'apres interpolation temporelle AMMA' 350 351 do k=1,nlev_amma 352 th_profamma(k)=0. 353 q_profamma(k)=0. 354 u_profamma(k)=0. 355 v_profamma(k)=0. 356 vt_profamma(k)=0. 357 vq_profamma(k)=0. 358 enddo 359 ! vertical interpolation using TOGA interpolation routine: 360 ! write(*,*)'avant interp vert', t_proftwp 361 CALL interp_toga_vertical(play,nlev_amma,plev_amma & 362 & ,th_profamma,q_profamma,u_profamma,v_profamma & 363 & ,vitw_profamma & 364 & ,ht_profamma,vt_profamma,hq_profamma,vq_profamma & 365 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 366 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 367 write(*,*) 'Profil initial forcing AMMA interpole' 368 369 370 !calcul de l'advection verticale a partir du omega 371 !Calcul des gradients verticaux 372 !initialisation 373 do l=1,llm 374 d_t_z(l)=0. 375 d_q_z(l)=0. 376 enddo 377 378 DO l=2,llm-1 379 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 380 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 381 ENDDO 382 d_t_z(1)=d_t_z(2) 383 d_q_z(1)=d_q_z(2) 384 d_t_z(llm)=d_t_z(llm-1) 385 d_q_z(llm)=d_q_z(llm-1) 386 387 388 do l = 1, llm 389 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 390 omega(l) = w_mod(l)*(-rg*rho(l)) 391 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 392 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 393 !calcul de l'advection totale 394 ! d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-omega(l)*d_t_z(l) 395 !attention: on impose dth 396 d_t_adv(l) = alpha*omega(l)/rcpd+ & 397 & ht_mod(l)*(play(l)/pzero)**rkappa-omega(l)*d_t_z(l) 398 ! d_t_adv(l) = 0. 399 ! print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l) 400 d_q_adv(l,1) = hq_mod(l)-omega(l)*d_q_z(l) 401 ! d_q_adv(l,1) = 0. 402 ! print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l) 403 404 dt_cooling(l) = 0.0 405 enddo 406 407 408 ! ok_flux_surf=.false. 409 fsens=-1.*sens_profamma 410 flat=-1.*lat_profamma 411 412 endif ! forcing_amma 413 414 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 415 !--------------------------------------------------------------------- 416 ! Interpolation forcing Rico 417 !--------------------------------------------------------------------- 418 if (forcing_rico) then 419 ! call lstendH(llm,omega,dt_dyn,dq_dyn,du_dyn, dv_dyn,q,temp,u,v,play) 420 call lstendH(llm,nqtot,omega,dt_dyn,dq_dyn,q,temp,u,v,play) 421 422 do l=1,llm 423 d_t_adv(l) = (dth_rico(l) + dt_dyn(l)) 424 d_q_adv(l,1) = (dqh_rico(l) + dq_dyn(l,1)) 425 d_q_adv(l,2) = 0. 426 enddo 427 endif ! forcing_rico 428 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 429 !--------------------------------------------------------------------- 430 ! Interpolation forcing Arm_cu 431 !--------------------------------------------------------------------- 432 if (forcing_armcu) then 433 434 print*, & 435 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_armcu=', & 436 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_armcu 437 438 ! time interpolation: 439 ! ATTENTION, cet appel ne convient pas pour TOGA !! 440 ! revoir 1DUTILS.h et les arguments 441 CALL interp_armcu_time(daytime,day1,annee_ref & 442 & ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu & 443 & ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu & 444 & ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof & 445 & ,adv_theta_prof,rad_theta_prof,adv_qt_prof) 446 447 ! vertical interpolation: 448 ! No vertical interpolation if nlev imposed to 19 or 40 449 450 ! For this case, fluxes are imposed 451 fsens=-1*sens_prof 452 flat=-1*flat_prof 453 454 ! Advective forcings are given in K or g/kg ... BY HOUR 455 do l = 1, llm 456 ug(l)= u_mod(l) 457 vg(l)= v_mod(l) 458 IF((phi(l)/RG).LT.1000) THEN 459 d_t_adv(l) = (adv_theta_prof + rad_theta_prof)/3600. 460 d_q_adv(l,1) = adv_qt_prof/1000./3600. 461 d_q_adv(l,2) = 0.0 462 ! print *,'INF1000: phi dth dq1 dq2', 463 ! : phi(l)/RG,d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 464 ELSEIF ((phi(l)/RG).GE.1000.AND.(phi(l)/RG).lt.3000) THEN 465 fact=((phi(l)/RG)-1000.)/2000. 466 fact=1-fact 467 d_t_adv(l) = (adv_theta_prof + rad_theta_prof)*fact/3600. 468 d_q_adv(l,1) = adv_qt_prof*fact/1000./3600. 469 d_q_adv(l,2) = 0.0 470 ! print *,'SUP1000: phi fact dth dq1 dq2', 471 ! : phi(l)/RG,fact,d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 472 ELSE 473 d_t_adv(l) = 0.0 474 d_q_adv(l,1) = 0.0 475 d_q_adv(l,2) = 0.0 476 ! print *,'SUP3000: phi dth dq1 dq2', 477 ! : phi(l)/RG,d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 478 ENDIF 479 dt_cooling(l) = 0.0 480 ! print *,'Interp armcu: phi dth dq1 dq2', 481 ! : l,phi(l),d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 482 enddo 483 endif ! forcing_armcu 484 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 485 !--------------------------------------------------------------------- 486 ! Interpolation forcing in time and onto model levels 487 !--------------------------------------------------------------------- 488 if (forcing_sandu) then 489 490 print*, & 491 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_sandu=', & 492 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_sandu 493 494 ! time interpolation: 495 ! ATTENTION, cet appel ne convient pas pour TOGA !! 496 ! revoir 1DUTILS.h et les arguments 497 CALL interp_sandu_time(daytime,day1,annee_ref & 498 & ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu & 499 & ,nlev_sandu & 500 & ,ts_sandu,ts_prof) 501 502 if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d 503 504 ! vertical interpolation: 505 CALL interp_sandu_vertical(play,nlev_sandu,plev_profs & 506 & ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs & 507 & ,omega_profs,o3mmr_profs & 508 & ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod & 509 & ,omega_mod,o3mmr_mod,mxcalc) 510 !calcul de l'advection verticale 511 !Calcul des gradients verticaux 512 !initialisation 513 d_t_z(:)=0. 514 d_q_z(:)=0. 515 d_t_dyn_z(:)=0. 516 d_q_dyn_z(:)=0. 517 ! schema centre 518 ! DO l=2,llm-1 519 ! d_t_z(l)=(temp(l+1)-temp(l-1)) 520 ! & /(play(l+1)-play(l-1)) 521 ! d_q_z(l)=(q(l+1,1)-q(l-1,1)) 522 ! & /(play(l+1)-play(l-1)) 523 ! schema amont 524 DO l=2,llm-1 525 d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l)) 526 d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l)) 527 ! print *,'l temp2 temp0 play2 play0 omega_mod', 528 ! & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l) 529 ENDDO 530 d_t_z(1)=d_t_z(2) 531 d_q_z(1)=d_q_z(2) 532 d_t_z(llm)=d_t_z(llm-1) 533 d_q_z(llm)=d_q_z(llm-1) 534 535 ! calcul de l advection verticale 536 ! Confusion w (m/s) et omega (Pa/s) !! 537 d_t_dyn_z(:)=omega_mod(:)*d_t_z(:) 538 d_q_dyn_z(:)=omega_mod(:)*d_q_z(:) 539 ! do l=1,llm 540 ! print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z', 541 ! :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l) 542 ! enddo 543 544 545 ! large-scale forcing : pour le cas Sandu ces forcages sont la SST 546 ! et une divergence constante -> profil de omega 547 tsurf = ts_prof 548 write(*,*) 'SST suivante: ',tsurf 549 do l = 1, llm 550 omega(l) = omega_mod(l) 551 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 552 553 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 554 ! 555 ! d_t_adv(l) = 0.0 556 ! d_q_adv(l,1) = 0.0 557 !CR:test advection=0 558 !calcul de l'advection verticale 559 d_t_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l) 560 ! print*,'temp adv',l,-d_t_dyn_z(l) 561 d_q_adv(l,1) = -d_q_dyn_z(l) 562 ! print*,'q adv',l,-d_q_dyn_z(l) 563 dt_cooling(l) = 0.0 564 enddo 565 endif ! forcing_sandu 566 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 567 !--------------------------------------------------------------------- 568 ! Interpolation forcing in time and onto model levels 569 !--------------------------------------------------------------------- 570 if (forcing_astex) then 571 572 print*, & 573 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_astex=', & 574 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_astex 575 576 ! time interpolation: 577 ! ATTENTION, cet appel ne convient pas pour TOGA !! 578 ! revoir 1DUTILS.h et les arguments 579 CALL interp_astex_time(daytime,day1,annee_ref & 580 & ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex & 581 & ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex & 582 & ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof & 583 & ,ufa_prof,vfa_prof) 584 585 if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d 586 587 ! vertical interpolation: 588 CALL interp_astex_vertical(play,nlev_astex,plev_profa & 589 & ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa & 590 & ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa & 591 & ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod & 592 & ,tke_mod,o3mmr_mod,mxcalc) 593 !calcul de l'advection verticale 594 !Calcul des gradients verticaux 595 !initialisation 596 d_t_z(:)=0. 597 d_q_z(:)=0. 598 d_t_dyn_z(:)=0. 599 d_q_dyn_z(:)=0. 600 ! schema centre 601 ! DO l=2,llm-1 602 ! d_t_z(l)=(temp(l+1)-temp(l-1)) 603 ! & /(play(l+1)-play(l-1)) 604 ! d_q_z(l)=(q(l+1,1)-q(l-1,1)) 605 ! & /(play(l+1)-play(l-1)) 606 ! schema amont 607 DO l=2,llm-1 608 d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l)) 609 d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l)) 610 ! print *,'l temp2 temp0 play2 play0 omega_mod', 611 ! & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l) 612 ENDDO 613 d_t_z(1)=d_t_z(2) 614 d_q_z(1)=d_q_z(2) 615 d_t_z(llm)=d_t_z(llm-1) 616 d_q_z(llm)=d_q_z(llm-1) 617 618 ! calcul de l advection verticale 619 ! Confusion w (m/s) et omega (Pa/s) !! 620 d_t_dyn_z(:)=w_mod(:)*d_t_z(:) 621 d_q_dyn_z(:)=w_mod(:)*d_q_z(:) 622 ! do l=1,llm 623 ! print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z', 624 ! :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l) 625 ! enddo 626 627 628 ! large-scale forcing : pour le cas Astex ces forcages sont la SST 629 ! la divergence,ug,vg,ufa,vfa 630 tsurf = ts_prof 631 write(*,*) 'SST suivante: ',tsurf 632 do l = 1, llm 633 omega(l) = w_mod(l) 634 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 635 636 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 637 ! 638 ! d_t_adv(l) = 0.0 639 ! d_q_adv(l,1) = 0.0 640 !CR:test advection=0 641 !calcul de l'advection verticale 642 d_t_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l) 643 ! print*,'temp adv',l,-d_t_dyn_z(l) 644 d_q_adv(l,1) = -d_q_dyn_z(l) 645 ! print*,'q adv',l,-d_q_dyn_z(l) 646 dt_cooling(l) = 0.0 647 enddo 648 endif ! forcing_astex 649 650 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 651 !--------------------------------------------------------------------- 652 ! Interpolation forcing standard case 653 !--------------------------------------------------------------------- 654 if (forcing_case) then 655 1 2 print*,'FORCING CASE forcing_case2' 656 3 print*, & 657 4 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=', & … … 660 7 661 8 ! time interpolation: 662 CALL interp_case_time(daytime,day1,annee_ref & 663 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 664 & ,nt_cas,nlev_cas & 665 & ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas,ug_cas,vg_cas & 666 & ,vitw_cas,du_cas,hu_cas,vu_cas & 667 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 668 & ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas & 669 & ,uw_cas,vw_cas,q1_cas,q2_cas & 670 & ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas & 671 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas & 672 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas & 673 & ,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas,lat_prof_cas & 674 & ,sens_prof_cas,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas) 675 676 ts_cur = ts_prof_cas 677 psurf=plev_prof_cas(1) 678 679 ! vertical interpolation: 680 CALL interp_case_vertical(play,nlev_cas,plev_prof_cas & 681 & ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas & 682 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 683 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & 684 & ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas & 685 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 686 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc) 687 688 689 !calcul de l'advection verticale a partir du omega 690 !Calcul des gradients verticaux 691 !initialisation 692 d_t_z(:)=0. 693 d_q_z(:)=0. 694 d_u_z(:)=0. 695 d_v_z(:)=0. 696 d_t_dyn_z(:)=0. 697 d_q_dyn_z(:)=0. 698 d_u_dyn_z(:)=0. 699 d_v_dyn_z(:)=0. 700 DO l=2,llm-1 701 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 702 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 703 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 704 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 705 ENDDO 706 d_t_z(1)=d_t_z(2) 707 d_q_z(1)=d_q_z(2) 708 d_u_z(1)=d_u_z(2) 709 d_v_z(1)=d_v_z(2) 710 d_t_z(llm)=d_t_z(llm-1) 711 d_q_z(llm)=d_q_z(llm-1) 712 d_u_z(llm)=d_u_z(llm-1) 713 d_v_z(llm)=d_v_z(llm-1) 714 715 !Calcul de l advection verticale 716 717 d_t_dyn_z(:)=w_mod_cas(:)*d_t_z(:) 718 719 d_q_dyn_z(:)=w_mod_cas(:)*d_q_z(:) 720 d_u_dyn_z(:)=w_mod_cas(:)*d_u_z(:) 721 d_v_dyn_z(:)=w_mod_cas(:)*d_v_z(:) 722 723 !wind nudging 724 if (nudge_u.gt.0.) then 725 do l=1,llm 726 u(l)=u(l)+timestep*(u_mod_cas(l)-u(l))/(nudge_u) 727 enddo 728 else 729 do l=1,llm 730 u(l) = u_mod_cas(l) 731 enddo 732 endif 733 734 if (nudge_v.gt.0.) then 735 do l=1,llm 736 v(l)=v(l)+timestep*(v_mod_cas(l)-v(l))/(nudge_v) 737 enddo 738 else 739 do l=1,llm 740 v(l) = v_mod_cas(l) 741 enddo 742 endif 743 744 if (nudge_w.gt.0.) then 745 do l=1,llm 746 w(l)=w(l)+timestep*(w_mod_cas(l)-w(l))/(nudge_w) 747 enddo 748 else 749 do l=1,llm 750 w(l) = w_mod_cas(l) 751 enddo 752 endif 753 754 !nudging of q and temp 755 if (nudge_t.gt.0.) then 756 do l=1,llm 757 temp(l)=temp(l)+timestep*(t_mod_cas(l)-temp(l))/(nudge_t) 758 enddo 759 endif 760 if (nudge_q.gt.0.) then 761 do l=1,llm 762 q(l,1)=q(l,1)+timestep*(q_mod_cas(l)-q(l,1))/(nudge_q) 763 enddo 764 endif 765 766 do l = 1, llm 767 omega(l) = w_mod_cas(l) ! juste car w_mod_cas en Pa/s (MPL 20170310) 768 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 769 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 770 771 !calcul advection 772 if ((tend_u.eq.1).and.(tend_w.eq.0)) then 773 d_u_adv(l)=du_mod_cas(l) 774 else if ((tend_u.eq.1).and.(tend_w.eq.1)) then 775 d_u_adv(l)=hu_mod_cas(l)-d_u_dyn_z(l) 776 endif 777 778 if ((tend_v.eq.1).and.(tend_w.eq.0)) then 779 d_v_adv(l)=dv_mod_cas(l) 780 else if ((tend_v.eq.1).and.(tend_w.eq.1)) then 781 d_v_adv(l)=hv_mod_cas(l)-d_v_dyn_z(l) 782 endif 783 784 if ((tend_t.eq.1).and.(tend_w.eq.0)) then 785 ! d_t_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l) 786 d_t_adv(l)=alpha*omega(l)/rcpd-dt_mod_cas(l) 787 else if ((tend_t.eq.1).and.(tend_w.eq.1)) then 788 ! d_t_adv(l)=alpha*omega(l)/rcpd+ht_mod_cas(l)-d_t_dyn_z(l) 789 d_t_adv(l)=alpha*omega(l)/rcpd-ht_mod_cas(l)-d_t_dyn_z(l) 790 endif 791 792 if ((tend_q.eq.1).and.(tend_w.eq.0)) then 793 ! d_q_adv(l,1)=dq_mod_cas(l) 794 d_q_adv(l,1)=-1*dq_mod_cas(l) 795 else if ((tend_q.eq.1).and.(tend_w.eq.1)) then 796 ! d_q_adv(l,1)=hq_mod_cas(l)-d_q_dyn_z(l) 797 d_q_adv(l,1)=-1*hq_mod_cas(l)-d_q_dyn_z(l) 798 endif 799 800 if (tend_rayo.eq.1) then 801 dt_cooling(l) = dtrad_mod_cas(l) 802 ! print *,'dt_cooling=',dt_cooling(l) 803 else 804 dt_cooling(l) = 0.0 805 endif 806 enddo 807 808 ! Faut-il multiplier par -1 ? (MPL 20160713) 809 IF(ok_flux_surf) THEN 810 fsens=sens_prof_cas 811 flat=lat_prof_cas 812 ENDIF 813 ! 814 IF (ok_prescr_ust) THEN 815 ust=ustar_prof_cas 816 print *,'ust=',ust 817 ENDIF 818 endif ! forcing_case 819 820 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 821 !--------------------------------------------------------------------- 822 ! Interpolation forcing standard case 823 !--------------------------------------------------------------------- 824 if (forcing_case2 .OR. forcing_SCM) then 825 826 print*, & 827 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=', & 828 & daytime,day1,(daytime-day1)*86400., & 829 & (daytime-day1)*86400/pdt_cas 830 831 ! time interpolation: 832 CALL interp2_case_time(daytime,day1,annee_ref & 9 CALL interp_case_time_std(daytime,day1,annee_ref & 833 10 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 834 11 & ,nt_cas,nlev_cas & … … 884 61 d_u_dyn_z(:)=0. 885 62 d_v_dyn_z(:)=0. 886 DO l=2,llm-1 887 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 888 d_th_z(l)=(teta(l+1)-teta(l-1))/(play(l+1)-play(l-1)) 889 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 890 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 891 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 892 ENDDO 63 if (1==0) then 64 DO l=2,llm-1 65 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 66 d_th_z(l)=(teta(l+1)-teta(l-1))/(play(l+1)-play(l-1)) 67 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 68 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 69 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 70 ENDDO 71 else 72 DO l=2,llm-1 73 IF (omega(l)>0.) THEN 74 d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l)) 75 d_th_z(l)=(teta(l+1)-teta(l))/(play(l+1)-play(l)) 76 d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l)) 77 d_u_z(l)=(u(l+1)-u(l))/(play(l+1)-play(l)) 78 d_v_z(l)=(v(l+1)-v(l))/(play(l+1)-play(l)) 79 ELSE 80 d_t_z(l)=(temp(l-1)-temp(l))/(play(l-1)-play(l)) 81 d_th_z(l)=(teta(l-1)-teta(l))/(play(l-1)-play(l)) 82 d_q_z(l)=(q(l-1,1)-q(l,1))/(play(l-1)-play(l)) 83 d_u_z(l)=(u(l-1)-u(l))/(play(l-1)-play(l)) 84 d_v_z(l)=(v(l-1)-v(l))/(play(l-1)-play(l)) 85 ENDIF 86 ENDDO 87 endif 88 d_t_z(1)=d_t_z(2) 893 89 d_t_z(1)=d_t_z(2) 894 90 d_th_z(1)=d_th_z(2) … … 902 98 d_v_z(llm)=d_v_z(llm-1) 903 99 100 ! TRAVAIL : PRENDRE DES NOTATIONS COHERENTES POUR W 101 do l = 1, llm 102 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309) 103 omega(l) = -w_mod_cas(l)*play(l)*rg/(rd*temp(l)) 104 enddo 105 904 106 !Calcul de l advection verticale 905 107 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170310) 906 d_t_dyn_z(:)=omega _mod_cas(:)*d_t_z(:)907 d_th_dyn_z(:)=omega _mod_cas(:)*d_th_z(:)908 d_q_dyn_z(:)=omega _mod_cas(:)*d_q_z(:)909 d_u_dyn_z(:)=omega _mod_cas(:)*d_u_z(:)910 d_v_dyn_z(:)=omega _mod_cas(:)*d_v_z(:)108 d_t_dyn_z(:)=omega(:)*d_t_z(:) 109 d_th_dyn_z(:)=omega(:)*d_th_z(:) 110 d_q_dyn_z(:)=omega(:)*d_q_z(:) 111 d_u_dyn_z(:)=omega(:)*d_u_z(:) 112 d_v_dyn_z(:)=omega(:)*d_v_z(:) 911 113 912 114 !geostrophic wind … … 962 164 do l = 1, llm 963 165 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309) 964 omega(l) = omega_mod_cas(l)965 166 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 966 167 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 967 168 968 169 !calcul advections 969 if ((forc_u.eq.1).and.(forc_w.eq.0)) then 970 d_u_adv(l)=du_mod_cas(l) 971 else if ((forc_u.eq.1).and.(forc_w.eq.1)) then 972 d_u_adv(l)=hu_mod_cas(l)-d_u_dyn_z(l) 973 endif 974 975 if ((forc_v.eq.1).and.(forc_w.eq.0)) then 976 d_v_adv(l)=dv_mod_cas(l) 977 else if ((forc_v.eq.1).and.(forc_w.eq.1)) then 978 d_v_adv(l)=hv_mod_cas(l)-d_v_dyn_z(l) 979 endif 980 981 ! Puisque dth a ete converti en dt, on traite de la meme facon 982 ! les flags tadv et thadv 983 if ((tadv.eq.1.or.thadv.eq.1) .and. (forc_w.eq.0)) then 984 ! d_t_adv(l)=alpha*omega(l)/rcpd-dt_mod_cas(l) 985 d_t_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l) 986 else if ((tadv.eq.1.or.thadv.eq.1) .and. (forc_w.eq.1)) then 987 ! d_t_adv(l)=alpha*omega(l)/rcpd-ht_mod_cas(l)-d_t_dyn_z(l) 988 d_t_adv(l)=alpha*omega(l)/rcpd+ht_mod_cas(l)-d_t_dyn_z(l) 989 endif 990 991 ! if ((thadv.eq.1) .and. (forc_w.eq.0)) then 992 ! d_t_adv(l)=alpha*omega(l)/rcpd-dth_mod_cas(l) 993 ! d_t_adv(l)=alpha*omega(l)/rcpd+dth_mod_cas(l) 994 ! else if ((thadv.eq.1) .and. (forc_w.eq.1)) then 995 ! d_t_adv(l)=alpha*omega(l)/rcpd-hth_mod_cas(l)-d_t_dyn_z(l) 996 ! d_t_adv(l)=alpha*omega(l)/rcpd+hth_mod_cas(l)-d_t_dyn_z(l) 997 ! endif 998 999 if ((qadv.eq.1) .and. (forc_w.eq.0)) then 1000 d_q_adv(l,1)=dq_mod_cas(l) 1001 ! d_q_adv(l,1)=-1*dq_mod_cas(l) 1002 else if ((qadv.eq.1) .and. (forc_w.eq.1)) then 1003 d_q_adv(l,1)=hq_mod_cas(l)-d_q_dyn_z(l) 1004 ! d_q_adv(l,1)=-1*hq_mod_cas(l)-d_q_dyn_z(l) 170 d_u_adv(l)=du_mod_cas(l) 171 d_v_adv(l)=dv_mod_cas(l) 172 d_t_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l) 173 d_q_adv(l,1)=dq_mod_cas(l) 174 175 if (forc_w==1) then 176 d_q_adv(l,1)=d_q_adv(l,1)-d_q_dyn_z(l) 177 d_t_adv(l)=d_t_adv(l)-d_t_dyn_z(l) 178 d_v_adv(l)=d_v_adv(l)-d_v_dyn_z(l) 179 d_u_adv(l)=d_u_adv(l)-d_u_dyn_z(l) 1005 180 endif 1006 181 … … 1025 200 print *,'ust=',ust 1026 201 ENDIF 1027 endif ! forcing_case21028 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1029 -
LMDZ6/trunk/libf/phylmd/dyn1d/1D_read_forc_cases.h
r3537 r3541 11 11 nq2=0 12 12 13 if (forcing_les .or. forcing_radconv & 14 & .or. forcing_GCSSold .or. forcing_fire) then 15 16 if (forcing_fire) then 17 !---------------------------------------------------------------------- 18 !read fire forcings from fire.nc 19 !---------------------------------------------------------------------- 20 fich_fire='fire.nc' 21 call read_fire(fich_fire,nlev_fire,nt_fire & 22 & ,height,tttprof,qtprof,uprof,vprof,e12prof & 23 & ,ugprof,vgprof,wfls,dqtdxls & 24 & ,dqtdyls,dqtdtls,thlpcar) 25 write(*,*) 'Forcing FIRE lu' 26 kmax=120 ! nombre de niveaux dans les profils et forcages 27 else 28 !---------------------------------------------------------------------- 29 ! Read profiles from files: prof.inp.001 and lscale.inp.001 30 ! (repris de readlesfiles) 31 !---------------------------------------------------------------------- 32 33 call readprofiles(nlev_max,kmax,nqtot,height, & 34 & tttprof,qtprof,uprof,vprof, & 35 & e12prof,ugprof,vgprof, & 36 & wfls,dqtdxls,dqtdyls,dqtdtls, & 37 & thlpcar,qprof,nq1,nq2) 38 endif 39 40 ! compute altitudes of play levels. 41 zlay(1) =zsurf + rd*tsurf*(psurf-play(1))/(rg*psurf) 42 do l = 2,llm 43 zlay(l) = zlay(l-1)+rd*tsurf*(psurf-play(1))/(rg*psurf) 44 enddo 45 46 !---------------------------------------------------------------------- 47 ! Interpolation of the profiles given on the input file to 48 ! model levels 49 !---------------------------------------------------------------------- 50 zlay(1) = zsurf + rd*tsurf*(psurf-play(1))/(rg*psurf) 51 do l=1,llm 52 ! Above the max altutide of the input file 53 54 if (zlay(l)<height(kmax)) mxcalc=l 55 56 frac = (height(kmax)-zlay(l))/(height (kmax)-height(kmax-1)) 57 ttt =tttprof(kmax)-frac*(tttprof(kmax)-tttprof(kmax-1)) 58 if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile 59 temp(l) = ttt*(play(l)/pzero)**rkappa 60 teta(l) = ttt 61 else 62 temp(l) = ttt 63 teta(l) = ttt*(pzero/play(l))**rkappa 64 endif 65 print *,' temp,teta ',l,temp(l),teta(l) 66 q(l,1) = qtprof(kmax)-frac*( qtprof(kmax)- qtprof(kmax-1)) 67 u(l) = uprof(kmax)-frac*( uprof(kmax)- uprof(kmax-1)) 68 v(l) = vprof(kmax)-frac*( vprof(kmax)- vprof(kmax-1)) 69 ug(l) = ugprof(kmax)-frac*( ugprof(kmax)- ugprof(kmax-1)) 70 vg(l) = vgprof(kmax)-frac*( vgprof(kmax)- vgprof(kmax-1)) 71 IF (nq2>0) q(l,nq1:nq2)=qprof(kmax,nq1:nq2) & 72 & -frac*(qprof(kmax,nq1:nq2)-qprof(kmax-1,nq1:nq2)) 73 omega(l)= wfls(kmax)-frac*( wfls(kmax)- wfls(kmax-1)) 74 75 dq_dyn(l,1) = dqtdtls(kmax)-frac*(dqtdtls(kmax)-dqtdtls(kmax-1)) 76 dt_cooling(l)=thlpcar(kmax)-frac*(thlpcar(kmax)-thlpcar(kmax-1)) 77 do k=2,kmax 78 print *,'k l height(k) height(k-1) zlay(l) frac=',k,l,height(k),height(k-1),zlay(l),frac 79 frac = (height(k)-zlay(l))/(height(k)-height(k-1)) 80 if(l==1) print*,'k, height, tttprof',k,height(k),tttprof(k) 81 if(zlay(l)>height(k-1).and.zlay(l)<height(k)) then 82 ttt =tttprof(k)-frac*(tttprof(k)-tttprof(k-1)) 83 if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile 84 temp(l) = ttt*(play(l)/pzero)**rkappa 85 teta(l) = ttt 86 else 87 temp(l) = ttt 88 teta(l) = ttt*(pzero/play(l))**rkappa 89 endif 90 print *,' temp,teta ',l,temp(l),teta(l) 91 q(l,1) = qtprof(k)-frac*( qtprof(k)- qtprof(k-1)) 92 u(l) = uprof(k)-frac*( uprof(k)- uprof(k-1)) 93 v(l) = vprof(k)-frac*( vprof(k)- vprof(k-1)) 94 ug(l) = ugprof(k)-frac*( ugprof(k)- ugprof(k-1)) 95 vg(l) = vgprof(k)-frac*( vgprof(k)- vgprof(k-1)) 96 IF (nq2>0) q(l,nq1:nq2)=qprof(k,nq1:nq2) & 97 & -frac*(qprof(k,nq1:nq2)-qprof(k-1,nq1:nq2)) 98 omega(l)= wfls(k)-frac*( wfls(k)- wfls(k-1)) 99 dq_dyn(l,1)=dqtdtls(k)-frac*(dqtdtls(k)-dqtdtls(k-1)) 100 dt_cooling(l)=thlpcar(k)-frac*(thlpcar(k)-thlpcar(k-1)) 101 elseif(zlay(l)<height(1)) then ! profils uniformes pour z<height(1) 102 ttt =tttprof(1) 103 if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile 104 temp(l) = ttt*(play(l)/pzero)**rkappa 105 teta(l) = ttt 106 else 107 temp(l) = ttt 108 teta(l) = ttt*(pzero/play(l))**rkappa 109 endif 110 q(l,1) = qtprof(1) 111 u(l) = uprof(1) 112 v(l) = vprof(1) 113 ug(l) = ugprof(1) 114 vg(l) = vgprof(1) 115 omega(l)= wfls(1) 116 IF (nq2>0) q(l,nq1:nq2)=qprof(1,nq1:nq2) 117 dq_dyn(l,1) =dqtdtls(1) 118 dt_cooling(l)=thlpcar(1) 119 endif 120 enddo 121 122 temp(l)=max(min(temp(l),350.),150.) 123 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 124 if (l .lt. llm) then 125 zlay(l+1) = zlay(l) + (play(l)-play(l+1))/(rg*rho(l)) 126 endif 127 omega2(l)=-rho(l)*omega(l) 128 omega(l)= omega(l)*(-rg*rho(l)) !en Pa/s 129 if (l>1) then 130 if(zlay(l-1)>height(kmax)) then 131 omega(l)=0.0 132 omega2(l)=0.0 133 endif 134 endif 135 if(q(l,1)<0.) q(l,1)=0.0 136 q(l,2) = 0.0 137 enddo 138 139 endif ! forcing_les .or. forcing_GCSSold .or. forcing_fire 140 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 141 !--------------------------------------------------------------------- 142 ! Forcing for GCSSold: 143 !--------------------------------------------------------------------- 144 if (forcing_GCSSold) then 145 fich_gcssold_ctl = './forcing.ctl' 146 fich_gcssold_dat = './forcing8.dat' 147 call copie(llm,play,psurf,fich_gcssold_ctl) 148 call get_uvd2(it,timestep,fich_gcssold_ctl,fich_gcssold_dat, & 149 & ht_gcssold,hq_gcssold,hw_gcssold, & 150 & hu_gcssold,hv_gcssold, & 151 & hthturb_gcssold,hqturb_gcssold,Ts_gcssold, & 152 & imp_fcg_gcssold,ts_fcg_gcssold, & 153 & Tp_fcg_gcssold,Turb_fcg_gcssold) 154 print *,' get_uvd2 -> hqturb_gcssold ',hqturb_gcssold 155 endif ! forcing_GCSSold 156 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 157 !--------------------------------------------------------------------- 158 ! Forcing for RICO: 159 !--------------------------------------------------------------------- 160 if (forcing_rico) then 161 162 ! call writefield_phy('omega', omega,llm+1) 163 fich_rico = 'rico.txt' 164 call read_rico(fich_rico,nlev_rico,ps_rico,play & 165 & ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico & 166 & ,dth_rico,dqh_rico) 167 print*, ' on a lu et prepare RICO' 168 169 mxcalc=llm 170 print *, airefi, ' airefi ' 171 do l = 1, llm 172 rho(l) = play(l)/(rd*t_rico(l)*(1.+(rv/rd-1.)*q_rico(l))) 173 temp(l) = t_rico(l) 174 q(l,1) = q_rico(l) 175 q(l,2) = 0.0 176 u(l) = u_rico(l) 177 v(l) = v_rico(l) 178 ug(l)=u_rico(l) 179 vg(l)=v_rico(l) 180 omega(l) = -w_rico(l)*rg 181 omega2(l) = omega(l)/rg*airefi 182 enddo 183 endif 184 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 185 !--------------------------------------------------------------------- 186 ! Forcing from TOGA-COARE experiment (Ciesielski et al. 2002) : 187 !--------------------------------------------------------------------- 188 189 if (forcing_toga) then 190 191 ! read TOGA-COARE forcing (native vertical grid, nt_toga timesteps): 192 fich_toga = './d_toga/ifa_toga_coare_v21_dime.txt' 193 CALL read_togacoare(fich_toga,nlev_toga,nt_toga & 194 & ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga & 195 & ,ht_toga,vt_toga,hq_toga,vq_toga) 196 197 write(*,*) 'Forcing TOGA lu' 198 199 ! time interpolation for initial conditions: 200 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 201 CALL interp_toga_time(daytime,day1,annee_ref & 202 & ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga & 203 & ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga & 204 & ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga & 205 & ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof & 206 & ,ht_prof,vt_prof,hq_prof,vq_prof) 207 208 ! vertical interpolation: 209 CALL interp_toga_vertical(play,nlev_toga,plev_prof & 210 & ,t_prof,q_prof,u_prof,v_prof,w_prof & 211 & ,ht_prof,vt_prof,hq_prof,vq_prof & 212 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 213 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 214 write(*,*) 'Profil initial forcing TOGA interpole' 215 216 ! initial and boundary conditions : 217 tsurf = ts_prof 218 write(*,*) 'SST initiale: ',tsurf 219 do l = 1, llm 220 temp(l) = t_mod(l) 221 q(l,1) = q_mod(l) 222 q(l,2) = 0.0 223 u(l) = u_mod(l) 224 v(l) = v_mod(l) 225 omega(l) = w_mod(l) 226 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 227 !? rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 228 !? omega2(l)=-rho(l)*omega(l) 229 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 230 d_t_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l)) 231 d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l)) 232 d_q_adv(l,2) = 0.0 233 enddo 234 235 endif ! forcing_toga 236 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 237 !--------------------------------------------------------------------- 238 ! Forcing from TWPICE experiment (Shaocheng et al. 2010) : 239 !--------------------------------------------------------------------- 240 241 if (forcing_twpice) then 242 !read TWP-ICE forcings 243 fich_twpice='d_twpi/twp180iopsndgvarana_v2.1_C3.c1.20060117.000000.cdf' 244 call read_twpice(fich_twpice,nlev_twpi,nt_twpi & 245 & ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi & 246 & ,ht_twpi,vt_twpi,hq_twpi,vq_twpi) 247 248 write(*,*) 'Forcing TWP-ICE lu' 249 !Time interpolation for initial conditions using TOGA interpolation routine 250 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 251 CALL interp_toga_time(daytime,day1,annee_ref & 252 & ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi & 253 & ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi & 254 & ,ht_twpi,vt_twpi,hq_twpi,vq_twpi & 255 & ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp & 256 & ,u_proftwp,v_proftwp,w_proftwp & 257 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp) 258 259 ! vertical interpolation using TOGA interpolation routine: 260 ! write(*,*)'avant interp vert', t_proftwp 261 CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp & 262 & ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp & 263 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp & 264 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 265 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 266 ! write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod 267 268 ! initial and boundary conditions : 269 ! tsurf = ts_proftwp 270 write(*,*) 'SST initiale: ',tsurf 271 do l = 1, llm 272 temp(l) = t_mod(l) 273 q(l,1) = q_mod(l) 274 q(l,2) = 0.0 275 u(l) = u_mod(l) 276 v(l) = v_mod(l) 277 omega(l) = w_mod(l) 278 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 279 280 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 281 !on applique le forcage total au premier pas de temps 282 !attention: signe different de toga 283 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l)) 284 d_q_adv(l,1) = (hq_mod(l)+vq_mod(l)) 285 d_q_adv(l,2) = 0.0 286 enddo 287 288 endif !forcing_twpice 289 290 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 291 !--------------------------------------------------------------------- 292 ! Forcing from AMMA experiment (Couvreux et al. 2010) : 293 !--------------------------------------------------------------------- 294 295 if (forcing_amma) then 296 297 call read_1D_cases 298 299 write(*,*) 'Forcing AMMA lu' 300 301 !champs initiaux: 302 do k=1,nlev_amma 303 th_ammai(k)=th_amma(k) 304 q_ammai(k)=q_amma(k) 305 u_ammai(k)=u_amma(k) 306 v_ammai(k)=v_amma(k) 307 vitw_ammai(k)=vitw_amma(k,12) 308 ht_ammai(k)=ht_amma(k,12) 309 hq_ammai(k)=hq_amma(k,12) 310 vt_ammai(k)=0. 311 vq_ammai(k)=0. 312 enddo 313 omega(:)=0. 314 omega2(:)=0. 315 rho(:)=0. 316 ! vertical interpolation using TOGA interpolation routine: 317 ! write(*,*)'avant interp vert', t_proftwp 318 CALL interp_toga_vertical(play,nlev_amma,plev_amma & 319 & ,th_ammai,q_ammai,u_ammai,v_ammai,vitw_ammai & 320 & ,ht_ammai,vt_ammai,hq_ammai,vq_ammai & 321 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 322 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 323 ! write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod 324 325 ! initial and boundary conditions : 326 ! tsurf = ts_proftwp 327 write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc 328 do l = 1, llm 329 ! Ligne du dessous ?? decommenter si on lit theta au lieu de temp 330 ! temp(l) = t_mod(l)*(play(l)/pzero)**rkappa 331 temp(l) = t_mod(l) 332 q(l,1) = q_mod(l) 333 q(l,2) = 0.0 334 ! print *,'read_forc: l,temp,q=',l,temp(l),q(l,1) 335 u(l) = u_mod(l) 336 v(l) = v_mod(l) 337 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 338 omega(l) = w_mod(l)*(-rg*rho(l)) 339 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 340 341 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 342 !on applique le forcage total au premier pas de temps 343 !attention: signe different de toga 344 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l) 345 !forcage en th 346 ! d_t_adv(l) = ht_mod(l) 347 d_q_adv(l,1) = hq_mod(l) 348 d_q_adv(l,2) = 0.0 349 dt_cooling(l)=0. 350 enddo 351 write(*,*) 'Prof initeforcing AMMA interpole temp39',temp(39) 352 353 354 ! ok_flux_surf=.false. 355 fsens=-1.*sens_amma(12) 356 flat=-1.*lat_amma(12) 357 358 endif !forcing_amma 359 360 361 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 362 !--------------------------------------------------------------------- 363 ! Forcing from DICE experiment (see file DICE_protocol_vn2-3.pdf) 364 !--------------------------------------------------------------------- 365 366 if (forcing_dice) then 367 !read DICE forcings 368 fich_dice='dice_driver.nc' 369 call read_dice(fich_dice,nlev_dice,nt_dice & 370 & ,zz_dice,plev_dice,t_dice,qv_dice,u_dice,v_dice,o3_dice & 371 & ,shf_dice,lhf_dice,lwup_dice,swup_dice,tg_dice,ustar_dice& 372 & ,psurf_dice,ug_dice,vg_dice,ht_dice,hq_dice & 373 & ,hu_dice,hv_dice,w_dice,omega_dice) 374 375 write(*,*) 'Forcing DICE lu' 376 377 !champs initiaux: 378 do k=1,nlev_dice 379 t_dicei(k)=t_dice(k) 380 qv_dicei(k)=qv_dice(k) 381 u_dicei(k)=u_dice(k) 382 v_dicei(k)=v_dice(k) 383 o3_dicei(k)=o3_dice(k) 384 ht_dicei(k)=ht_dice(k,1) 385 hq_dicei(k)=hq_dice(k,1) 386 hu_dicei(k)=hu_dice(k,1) 387 hv_dicei(k)=hv_dice(k,1) 388 w_dicei(k)=w_dice(k,1) 389 omega_dicei(k)=omega_dice(k,1) 390 enddo 391 omega(:)=0. 392 omega2(:)=0. 393 rho(:)=0. 394 ! vertical interpolation using TOGA interpolation routine: 395 ! write(*,*)'avant interp vert', t_proftwp 396 ! 397 ! CALL interp_dice_time(daytime,day1,annee_ref 398 ! i ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice 399 ! i ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice 400 ! i ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice 401 ! i ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice 402 ! o ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof 403 ! o ,ustar_prof,psurf_prof,ug_profd,vg_profd 404 ! o ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd 405 ! o ,omega_profd) 406 407 CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice & 408 & ,t_dicei,qv_dicei,u_dicei,v_dicei,o3_dicei & 409 & ,ht_dicei,hq_dicei,hu_dicei,hv_dicei,w_dicei,omega_dicei& 410 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 411 & ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc) 412 413 ! Pour tester les advections horizontales de T et Q, on met w_mod et omega_mod ?? zero (MPL 20131108) 414 ! w_mod(:,:)=0. 415 ! omega_mod(:,:)=0. 416 417 ! write(*,*) 'Profil initial forcing DICE interpole',t_mod 418 ! Les forcages DICE sont donnes /jour et non /seconde ! 419 ht_mod(:)=ht_mod(:)/86400. 420 hq_mod(:)=hq_mod(:)/86400. 421 hu_mod(:)=hu_mod(:)/86400. 422 hv_mod(:)=hv_mod(:)/86400. 423 424 ! initial and boundary conditions : 425 write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc 426 do l = 1, llm 427 ! Ligne du dessous ?? decommenter si on lit theta au lieu de temp 428 ! temp(l) = th_mod(l)*(play(l)/pzero)**rkappa 429 temp(l) = t_mod(l) 430 q(l,1) = qv_mod(l) 431 q(l,2) = 0.0 432 ! print *,'read_forc: l,temp,q=',l,temp(l),q(l,1) 433 u(l) = u_mod(l) 434 v(l) = v_mod(l) 435 ug(l)=ug_dice(1) 436 vg(l)=vg_dice(1) 437 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 438 ! omega(l) = w_mod(l)*(-rg*rho(l)) 439 omega(l) = omega_mod(l) 440 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 441 442 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 443 !on applique le forcage total au premier pas de temps 444 !attention: signe different de toga 445 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l) 446 !forcage en th 447 ! d_t_adv(l) = ht_mod(l) 448 d_q_adv(l,1) = hq_mod(l) 449 d_q_adv(l,2) = 0.0 450 dt_cooling(l)=0. 451 enddo 452 write(*,*) 'Profil initial forcing DICE interpole temp39',temp(39) 453 454 455 ! ok_flux_surf=.false. 456 fsens=-1.*shf_dice(1) 457 flat=-1.*lhf_dice(1) 458 ! Le cas Dice doit etre force avec ustar mais on peut simplifier en forcant par 459 ! le coefficient de trainee en surface cd**2=ustar*vent(k=1) 460 ! On commence ici a stocker ustar dans cdrag puis on terminera le calcul dans pbl_surface 461 ! MPL 05082013 462 ust=ustar_dice(1) 463 tg=tg_dice(1) 464 print *,'ust= ',ust 465 IF (tsurf .LE. 0.) THEN 466 tsurf= tg_dice(1) 467 ENDIF 468 psurf= psurf_dice(1) 469 solsw_in = (1.-albedo)/albedo*swup_dice(1) 470 sollw_in = (0.7*RSIGMA*temp(1)**4)-lwup_dice(1) 471 PRINT *,'1D_READ_FORC : solsw, sollw',solsw_in,sollw_in 472 endif !forcing_dice 473 474 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 475 !--------------------------------------------------------------------- 476 ! Forcing from GABLS4 experiment 477 !--------------------------------------------------------------------- 478 479 !!!! Si la temperature de surface n'est pas impos??e: 480 481 if (forcing_gabls4) then 482 !read GABLS4 forcings 483 484 fich_gabls4='gabls4_driver.nc' 485 486 487 call read_gabls4(fich_gabls4,nlev_gabls4,nt_gabls4,nsol_gabls4,zz_gabls4,depth_sn_gabls4,ug_gabls4,vg_gabls4 & 488 & ,plev_gabls4,th_gabls4,t_gabls4,qv_gabls4,u_gabls4,v_gabls4,ht_gabls4,hq_gabls4,tg_gabls4,tsnow_gabls4,snow_dens_gabls4) 489 490 write(*,*) 'Forcing GABLS4 lu' 491 492 !champs initiaux: 493 do k=1,nlev_gabls4 494 t_gabi(k)=t_gabls4(k) 495 qv_gabi(k)=qv_gabls4(k) 496 u_gabi(k)=u_gabls4(k) 497 v_gabi(k)=v_gabls4(k) 498 poub(k)=0. 499 ht_gabi(k)=ht_gabls4(k,1) 500 hq_gabi(k)=hq_gabls4(k,1) 501 ug_gabi(k)=ug_gabls4(k,1) 502 vg_gabi(k)=vg_gabls4(k,1) 503 enddo 504 505 omega(:)=0. 506 omega2(:)=0. 507 rho(:)=0. 508 ! vertical interpolation using TOGA interpolation routine: 509 ! write(*,*)'avant interp vert', t_proftwp 510 ! 511 ! CALL interp_dice_time(daytime,day1,annee_ref 512 ! i ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice 513 ! i ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice 514 ! i ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice 515 ! i ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice 516 ! o ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof 517 ! o ,ustar_prof,psurf_prof,ug_profd,vg_profd 518 ! o ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd 519 ! o ,omega_profd) 520 521 CALL interp_dice_vertical(play,nlev_gabls4,nt_gabls4,plev_gabls4 & 522 & ,t_gabi,qv_gabi,u_gabi,v_gabi,poub & 523 & ,ht_gabi,hq_gabi,ug_gabi,vg_gabi,poub,poub & 524 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 525 & ,ht_mod,hq_mod,ug_mod,vg_mod,w_mod,omega_mod,mxcalc) 526 527 ! Les forcages GABLS4 ont l air d etre en K/S quoiqu en dise le fichier gabls4_driver.nc !? MPL 20141024 528 ! ht_mod(:)=ht_mod(:)/86400. 529 ! hq_mod(:)=hq_mod(:)/86400. 530 531 ! initial and boundary conditions : 532 write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc 533 do l = 1, llm 534 ! Ligne du dessous ?? decommenter si on lit theta au lieu de temp 535 ! temp(l) = th_mod(l)*(play(l)/pzero)**rkappa 536 temp(l) = t_mod(l) 537 q(l,1) = qv_mod(l) 538 q(l,2) = 0.0 539 ! print *,'read_forc: l,temp,q=',l,temp(l),q(l,1) 540 u(l) = u_mod(l) 541 v(l) = v_mod(l) 542 ug(l)=ug_mod(l) 543 vg(l)=vg_mod(l) 544 545 ! 546 ! tg=tsurf 547 ! 548 549 print *,'***** tsurf=',tsurf 550 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 551 ! omega(l) = w_mod(l)*(-rg*rho(l)) 552 omega(l) = omega_mod(l) 553 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 554 555 556 557 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 558 !on applique le forcage total au premier pas de temps 559 !attention: signe different de toga 560 ! d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l) 561 !forcage en th 562 d_t_adv(l) = ht_mod(l) 563 d_q_adv(l,1) = hq_mod(l) 564 d_q_adv(l,2) = 0.0 565 dt_cooling(l)=0. 566 enddo 567 568 !--------------- Residus forcages du cas Dice (a supprimer) MPL 20141024--------------- 569 ! Le cas Dice doit etre force avec ustar mais on peut simplifier en forcant par 570 ! le coefficient de trainee en surface cd**2=ustar*vent(k=1) 571 ! On commence ici a stocker ustar dans cdrag puis on terminera le calcul dans pbl_surface 572 ! MPL 05082013 573 ! ust=ustar_dice(1) 574 ! tg=tg_dice(1) 575 ! print *,'ust= ',ust 576 ! IF (tsurf .LE. 0.) THEN 577 ! tsurf= tg_dice(1) 578 ! ENDIF 579 ! psurf= psurf_dice(1) 580 ! solsw_in = (1.-albedo)/albedo*swup_dice(1) 581 ! sollw_in = (0.7*RSIGMA*temp(1)**4)-lwup_dice(1) 582 ! PRINT *,'1D_READ_FORC : solsw, sollw',solsw_in,sollw_in 583 !-------------------------------------------------------------------------------------- 584 endif !forcing_gabls4 585 586 587 588 ! Forcing from Arm_Cu case 589 ! For this case, ifa_armcu.txt contains sensible, latent heat fluxes 590 ! large scale advective forcing,radiative forcing 591 ! and advective tendency of theta and qt to be applied 592 !--------------------------------------------------------------------- 593 594 if (forcing_armcu) then 595 ! read armcu forcing : 596 write(*,*) 'Avant lecture Forcing Arm_Cu' 597 fich_armcu = './ifa_armcu.txt' 598 CALL read_armcu(fich_armcu,nlev_armcu,nt_armcu, & 599 & sens_armcu,flat_armcu,adv_theta_armcu, & 600 & rad_theta_armcu,adv_qt_armcu) 601 write(*,*) 'Forcing Arm_Cu lu' 602 603 !---------------------------------------------------------------------- 604 ! Read profiles from file: prof.inp.19 or prof.inp.40 605 ! For this case, profiles are given for two vertical resolution 606 ! 19 or 40 levels 607 ! 608 ! Comment from: http://www.knmi.nl/samenw/eurocs/ARM/profiles.html 609 ! Note that the initial profiles contain no liquid water! 610 ! (so potential temperature can be interpreted as liquid water 611 ! potential temperature and water vapor as total water) 612 ! profiles are given at full levels 613 !---------------------------------------------------------------------- 614 615 call readprofile_armcu(nlev_max,kmax,height,play_mod,u_mod, & 616 & v_mod,theta_mod,t_mod,qv_mod,rv_mod,ap,bp) 617 618 ! time interpolation for initial conditions: 619 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 620 621 print *,'Avant interp_armcu_time' 622 print *,'daytime=',daytime 623 print *,'day1=',day1 624 print *,'annee_ref=',annee_ref 625 print *,'year_ini_armcu=',year_ini_armcu 626 print *,'day_ju_ini_armcu=',day_ju_ini_armcu 627 print *,'nt_armcu=',nt_armcu 628 print *,'dt_armcu=',dt_armcu 629 print *,'nlev_armcu=',nlev_armcu 630 CALL interp_armcu_time(daytime,day1,annee_ref & 631 & ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu & 632 & ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu & 633 & ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof & 634 & ,adv_theta_prof,rad_theta_prof,adv_qt_prof) 635 write(*,*) 'Forcages interpoles dans temps' 636 637 ! No vertical interpolation if nlev imposed to 19 or 40 638 ! The vertical grid stops at 4000m # 600hPa 639 mxcalc=llm 640 641 ! initial and boundary conditions : 642 ! tsurf = ts_prof 643 ! tsurf read in lmdz1d.def 644 write(*,*) 'Tsurf initiale: ',tsurf 645 do l = 1, llm 646 play(l)=play_mod(l)*100. 647 presnivs(l)=play(l) 648 zlay(l)=height(l) 649 temp(l) = t_mod(l) 650 teta(l)=theta_mod(l) 651 q(l,1) = qv_mod(l)/1000. 652 ! No liquid water in the initial profil 653 q(l,2) = 0. 654 u(l) = u_mod(l) 655 ug(l)= u_mod(l) 656 v(l) = v_mod(l) 657 vg(l)= v_mod(l) 658 ! Advective forcings are given in K or g/kg ... per HOUR 659 ! IF(height(l).LT.1000) THEN 660 ! d_t_adv(l) = (adv_theta_prof + rad_theta_prof)/3600. 661 ! d_q_adv(l,1) = adv_qt_prof/1000./3600. 662 ! d_q_adv(l,2) = 0.0 663 ! ELSEIF (height(l).GE.1000.AND.height(l).LT.3000) THEN 664 ! d_t_adv(l) = (adv_theta_prof + rad_theta_prof)* 665 ! : (1-(height(l)-1000.)/2000.) 666 ! d_t_adv(l) = d_t_adv(l)/3600. 667 ! d_q_adv(l,1) = adv_qt_prof*(1-(height(l)-1000.)/2000.) 668 ! d_q_adv(l,1) = d_q_adv(l,1)/1000./3600. 669 ! d_q_adv(l,2) = 0.0 670 ! ELSE 671 ! d_t_adv(l) = 0.0 672 ! d_q_adv(l,1) = 0.0 673 ! d_q_adv(l,2) = 0.0 674 ! ENDIF 675 enddo 676 ! plev at half levels is given in proh.inp.19 or proh.inp.40 files 677 plev(1)= ap(llm+1)+bp(llm+1)*psurf 678 do l = 1, llm 679 plev(l+1) = ap(llm-l+1)+bp(llm-l+1)*psurf 680 print *,'Read_forc: l height play plev zlay temp', & 681 & l,height(l),play(l),plev(l),zlay(l),temp(l) 682 enddo 683 ! For this case, fluxes are imposed 684 fsens=-1*sens_prof 685 flat=-1*flat_prof 686 687 endif ! forcing_armcu 688 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 689 !--------------------------------------------------------------------- 690 ! Forcing from transition case of Irina Sandu 691 !--------------------------------------------------------------------- 692 693 if (forcing_sandu) then 694 write(*,*) 'Avant lecture Forcing SANDU' 695 696 ! read sanduref forcing : 697 fich_sandu = './ifa_sanduref.txt' 698 CALL read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu) 699 700 write(*,*) 'Forcing SANDU lu' 701 702 !---------------------------------------------------------------------- 703 ! Read profiles from file: prof.inp.001 704 !---------------------------------------------------------------------- 705 706 call readprofile_sandu(nlev_max,kmax,height,plev_profs,t_profs, & 707 & thl_profs,q_profs,u_profs,v_profs, & 708 & w_profs,omega_profs,o3mmr_profs) 709 710 ! time interpolation for initial conditions: 711 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 712 ! ATTENTION, cet appel ne convient pas pour le cas SANDU !! 713 ! revoir 1DUTILS.h et les arguments 714 715 print *,'Avant interp_sandu_time' 716 print *,'daytime=',daytime 717 print *,'day1=',day1 718 print *,'annee_ref=',annee_ref 719 print *,'year_ini_sandu=',year_ini_sandu 720 print *,'day_ju_ini_sandu=',day_ju_ini_sandu 721 print *,'nt_sandu=',nt_sandu 722 print *,'dt_sandu=',dt_sandu 723 print *,'nlev_sandu=',nlev_sandu 724 CALL interp_sandu_time(daytime,day1,annee_ref & 725 & ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu & 726 & ,nlev_sandu & 727 & ,ts_sandu,ts_prof) 728 729 ! vertical interpolation: 730 print *,'Avant interp_vertical: nlev_sandu=',nlev_sandu 731 CALL interp_sandu_vertical(play,nlev_sandu,plev_profs & 732 & ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs & 733 & ,omega_profs,o3mmr_profs & 734 & ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod & 735 & ,omega_mod,o3mmr_mod,mxcalc) 736 write(*,*) 'Profil initial forcing SANDU interpole' 737 738 ! initial and boundary conditions : 739 tsurf = ts_prof 740 write(*,*) 'SST initiale: ',tsurf 741 do l = 1, llm 742 temp(l) = t_mod(l) 743 tetal(l)=thl_mod(l) 744 q(l,1) = q_mod(l) 745 q(l,2) = 0.0 746 u(l) = u_mod(l) 747 v(l) = v_mod(l) 748 w(l) = w_mod(l) 749 omega(l) = omega_mod(l) 750 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 751 !? rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 752 !? omega2(l)=-rho(l)*omega(l) 753 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 754 ! d_t_adv(l) = alpha*omega(l)/rcpd+vt_mod(l) 755 ! d_q_adv(l,1) = vq_mod(l) 756 d_t_adv(l) = alpha*omega(l)/rcpd 757 d_q_adv(l,1) = 0.0 758 d_q_adv(l,2) = 0.0 759 enddo 760 761 endif ! forcing_sandu 762 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 763 !--------------------------------------------------------------------- 764 ! Forcing from Astex case 765 !--------------------------------------------------------------------- 766 767 if (forcing_astex) then 768 write(*,*) 'Avant lecture Forcing Astex' 769 770 ! read astex forcing : 771 fich_astex = './ifa_astex.txt' 772 CALL read_astex(fich_astex,nlev_astex,nt_astex,div_astex,ts_astex, & 773 & ug_astex,vg_astex,ufa_astex,vfa_astex) 774 775 write(*,*) 'Forcing Astex lu' 776 777 !---------------------------------------------------------------------- 778 ! Read profiles from file: prof.inp.001 779 !---------------------------------------------------------------------- 780 781 call readprofile_astex(nlev_max,kmax,height,plev_profa,t_profa, & 782 & thl_profa,qv_profa,ql_profa,qt_profa,u_profa,v_profa, & 783 & w_profa,tke_profa,o3mmr_profa) 784 785 ! time interpolation for initial conditions: 786 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 787 ! ATTENTION, cet appel ne convient pas pour le cas SANDU !! 788 ! revoir 1DUTILS.h et les arguments 789 790 print *,'Avant interp_astex_time' 791 print *,'daytime=',daytime 792 print *,'day1=',day1 793 print *,'annee_ref=',annee_ref 794 print *,'year_ini_astex=',year_ini_astex 795 print *,'day_ju_ini_astex=',day_ju_ini_astex 796 print *,'nt_astex=',nt_astex 797 print *,'dt_astex=',dt_astex 798 print *,'nlev_astex=',nlev_astex 799 CALL interp_astex_time(daytime,day1,annee_ref & 800 & ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex & 801 & ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex & 802 & ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof & 803 & ,ufa_prof,vfa_prof) 804 805 ! vertical interpolation: 806 print *,'Avant interp_vertical: nlev_astex=',nlev_astex 807 CALL interp_astex_vertical(play,nlev_astex,plev_profa & 808 & ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa & 809 & ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa & 810 & ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod & 811 & ,tke_mod,o3mmr_mod,mxcalc) 812 write(*,*) 'Profil initial forcing Astex interpole' 813 814 ! initial and boundary conditions : 815 tsurf = ts_prof 816 write(*,*) 'SST initiale: ',tsurf 817 do l = 1, llm 818 temp(l) = t_mod(l) 819 tetal(l)=thl_mod(l) 820 q(l,1) = qv_mod(l) 821 q(l,2) = ql_mod(l) 822 u(l) = u_mod(l) 823 v(l) = v_mod(l) 824 w(l) = w_mod(l) 825 omega(l) = w_mod(l) 826 ! omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 827 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 828 ! omega2(l)=-rho(l)*omega(l) 829 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 830 ! d_t_adv(l) = alpha*omega(l)/rcpd+vt_mod(l) 831 ! d_q_adv(l,1) = vq_mod(l) 832 d_t_adv(l) = alpha*omega(l)/rcpd 833 d_q_adv(l,1) = 0.0 834 d_q_adv(l,2) = 0.0 835 enddo 836 837 endif ! forcing_astex 838 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 839 !--------------------------------------------------------------------- 840 ! Forcing from standard case : 841 !--------------------------------------------------------------------- 842 843 if (forcing_case) then 844 845 write(*,*),'avant call read_1D_cas' 846 call read_1D_cas 847 write(*,*) 'Forcing read' 848 849 !Time interpolation for initial conditions using TOGA interpolation routine 850 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 851 CALL interp_case_time(day,day1,annee_ref & 852 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 853 & ,nt_cas,nlev_cas & 854 & ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas & 855 & ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas & 856 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 857 & ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas & 858 & ,uw_cas,vw_cas,q1_cas,q2_cas & 859 & ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas & 860 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas & 861 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas & 862 & ,dq_prof_cas,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas,ustar_prof_cas & 863 & ,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas) 864 865 ! vertical interpolation using TOGA interpolation routine: 866 ! write(*,*)'avant interp vert', t_prof 867 CALL interp_case_vertical(play,nlev_cas,plev_prof_cas & 868 & ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas & 869 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 870 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & 871 & ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas & 872 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 873 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc) 874 ! write(*,*) 'Profil initial forcing case interpole',t_mod 875 876 ! initial and boundary conditions : 877 ! tsurf = ts_prof_cas 878 ts_cur = ts_prof_cas 879 psurf=plev_prof_cas(1) 880 write(*,*) 'SST initiale: ',tsurf 881 do l = 1, llm 882 temp(l) = t_mod_cas(l) 883 q(l,1) = q_mod_cas(l) 884 q(l,2) = 0.0 885 u(l) = u_mod_cas(l) 886 v(l) = v_mod_cas(l) 887 omega(l) = w_mod_cas(l) 888 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 889 890 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 891 !on applique le forcage total au premier pas de temps 892 !attention: signe different de toga 893 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l)) 894 d_q_adv(l,1) = (hq_mod_cas(l)+vq_mod_cas(l)) 895 d_q_adv(l,2) = 0.0 896 d_u_adv(l) = (hu_mod_cas(l)+vu_mod_cas(l)) 897 ! correction bug d_u -> d_v (MM+MPL 20170310) 898 d_v_adv(l) = (hv_mod_cas(l)+vv_mod_cas(l)) 899 enddo 900 901 ! In case fluxes are imposed 902 IF (ok_flux_surf) THEN 903 fsens=sens_prof_cas 904 flat=lat_prof_cas 905 ENDIF 906 IF (ok_prescr_ust) THEN 907 ust=ustar_prof_cas 908 print *,'ust=',ust 909 ENDIF 910 911 endif !forcing_case 912 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 913 !--------------------------------------------------------------------- 914 ! Forcing from standard case : 915 !--------------------------------------------------------------------- 916 917 if (forcing_case2) then 918 919 write(*,*),'avant call read2_1D_cas' 920 call read2_1D_cas 921 write(*,*) 'Forcing read' 922 923 !Time interpolation for initial conditions using interpolation routine 924 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 925 CALL interp2_case_time(daytime,day1,annee_ref & 926 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 927 & ,nt_cas,nlev_cas & 928 & ,ts_cas,ps_cas,plev_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,ql_cas,qi_cas & 929 & ,u_cas,v_cas,ug_cas,vg_cas,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas & 930 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 931 & ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,lat_cas,sens_cas,ustar_cas & 932 & ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas & 933 ! 934 & ,ts_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas & 935 & ,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas & 936 & ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas & 937 & ,du_prof_cas,hu_prof_cas,vu_prof_cas & 938 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas & 939 & ,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & 940 & ,dth_prof_cas,hth_prof_cas,vth_prof_cas,lat_prof_cas & 941 & ,sens_prof_cas,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas,tke_prof_cas) 942 943 do l = 1, nlev_cas 944 print *,'apres 1ere interp: plev_cas, plev_prof_cas=',l,plev_cas(l,1),plev_prof_cas(l) 945 enddo 946 947 ! vertical interpolation using interpolation routine: 948 ! write(*,*)'avant interp vert', t_prof 949 CALL interp2_case_vertical(play,nlev_cas,plev_prof_cas & 950 & ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas & 951 & ,qv_prof_cas,ql_prof_cas,qi_prof_cas,u_prof_cas,v_prof_cas & 952 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas & 953 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 954 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & 955 & ,dth_prof_cas,hth_prof_cas,vth_prof_cas & 956 ! 957 & ,t_mod_cas,theta_mod_cas,thv_mod_cas,thl_mod_cas,qv_mod_cas,ql_mod_cas,qi_mod_cas & 958 & ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas,omega_mod_cas & 959 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 960 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas & 961 & ,dth_mod_cas,hth_mod_cas,vth_mod_cas,mxcalc) 962 963 ! write(*,*) 'Profil initial forcing case interpole',t_mod 964 965 ! initial and boundary conditions : 966 ! tsurf = ts_prof_cas 967 ts_cur = ts_prof_cas 968 psurf=plev_prof_cas(1) 969 write(*,*) 'SST initiale: ',tsurf 970 do l = 1, llm 971 temp(l) = t_mod_cas(l) 972 q(l,1) = qv_mod_cas(l) 973 q(l,2) = ql_mod_cas(l) 974 u(l) = u_mod_cas(l) 975 ug(l)= ug_mod_cas(l) 976 v(l) = v_mod_cas(l) 977 vg(l)= vg_mod_cas(l) 978 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309) 979 omega(l) = omega_mod_cas(l) 980 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 981 982 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 983 !on applique le forcage total au premier pas de temps 984 !attention: signe different de toga 985 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l)) 986 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l)) 987 ! d_q_adv(l,1) = (hq_mod_cas(l)+vq_mod_cas(l)) 988 d_q_adv(l,1) = dq_mod_cas(l) 989 d_q_adv(l,2) = 0.0 990 ! d_u_adv(l) = (hu_mod_cas(l)+vu_mod_cas(l)) 991 d_u_adv(l) = du_mod_cas(l) 992 ! d_v_adv(l) = (hv_mod_cas(l)+vv_mod_cas(l)) 993 ! correction bug d_u -> d_v (MM+MPL 20170310) 994 d_v_adv(l) = dv_mod_cas(l) 995 enddo 996 997 ! Faut-il multiplier par -1 ? (MPL 20160713) 998 IF (ok_flux_surf) THEN 999 fsens=-1.*sens_prof_cas 1000 flat=-1.*lat_prof_cas 1001 ENDIF 1002 ! 1003 IF (ok_prescr_ust) THEN 1004 ust=ustar_prof_cas 1005 print *,'ust=',ust 1006 ENDIF 1007 1008 endif !forcing_case2 1009 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1011 !--------------------------------------------------------------------- 1012 ! Forcing from standard case : 1013 !--------------------------------------------------------------------- 1014 13 print*,'FORCING ,forcing_SCM',forcing_SCM 1015 14 if (forcing_SCM) then 1016 15 … … 1021 20 !Time interpolation for initial conditions using interpolation routine 1022 21 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 1023 CALL interp 2_case_time(daytime,day1,annee_ref &22 CALL interp_case_time_std(daytime,day1,annee_ref & 1024 23 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 1025 24 & ,nt_cas,nlev_cas & -
LMDZ6/trunk/libf/phylmd/dyn1d/lmdz1d.F90
r3540 r3541 9 9 10 10 11 11 PROGRAM lmdz1d 12 12 13 USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar 14 USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, & 15 clwcon, detr_therm, & 16 qsol, fevap, z0m, z0h, agesno, & 17 du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, & 18 falb_dir, falb_dif, & 19 ftsol, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, & 20 rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, & 21 solsw, t_ancien, q_ancien, u_ancien, v_ancien, wake_cstar, & 22 wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, & 23 wake_deltaq, wake_deltat, wake_s, wake_dens, & 24 zgam, zmax0, zmea, zpic, zsig, & 25 zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, & 26 prlw_ancien, prsw_ancien, prw_ancien 27 28 USE dimphy 29 USE surface_data, only : type_ocean,ok_veget 30 USE pbl_surface_mod, only : ftsoil, pbl_surface_init, & 31 pbl_surface_final 32 USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final 13 USE ioipsl, only: getin 33 14 34 USE infotrac ! new 35 USE control_mod 36 USE indice_sol_mod 37 USE phyaqua_mod 38 ! USE mod_1D_cases_read 39 USE mod_1D_cases_read2 40 USE mod_1D_amma_read 41 USE print_control_mod, ONLY: lunout, prt_level 42 USE iniphysiq_mod, ONLY: iniphysiq 43 USE mod_const_mpi, ONLY: comm_lmdz 44 USE physiq_mod, ONLY: physiq 45 USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, & 46 preff, aps, bps, pseudoalt, scaleheight 47 USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, & 48 itau_dyn, itau_phy, start_time, year_len 49 USE phys_cal_mod, ONLY : year_len_phys_cal_mod => year_len 15 INTEGER forcing_type 50 16 51 implicit none 52 #include "dimensions.h" 53 #include "YOMCST.h" 54 !!#include "control.h" 55 #include "clesphys.h" 56 #include "dimsoil.h" 57 !#include "indicesol.h" 17 CALL getin('forcing_type',forcing_type) 58 18 59 #include "compar1d.h" 60 #include "flux_arp.h" 61 #include "date_cas.h" 62 #include "tsoilnudge.h" 63 #include "fcg_gcssold.h" 64 !!!#include "fbforcing.h" 65 #include "compbl.h" 19 IF (forcing_type==1000) THEN 20 CALL scm 21 ELSE 22 CALL old_lmdz1d 23 ENDIF 66 24 67 !===================================================================== 68 ! DECLARATIONS 69 !===================================================================== 25 END 70 26 71 !---------------------------------------------------------------------72 ! Externals73 !---------------------------------------------------------------------74 external fq_sat75 real fq_sat76 77 !---------------------------------------------------------------------78 ! Arguments d' initialisations de la physique (USER DEFINE)79 !---------------------------------------------------------------------80 81 integer, parameter :: ngrid=182 real :: zcufi = 1.83 real :: zcvfi = 1.84 85 !- real :: nat_surf86 !- logical :: ok_flux_surf87 !- real :: fsens88 !- real :: flat89 !- real :: tsurf90 !- real :: rugos91 !- real :: qsol(1:2)92 !- real :: qsurf93 !- real :: psurf94 !- real :: zsurf95 !- real :: albedo96 !-97 !- real :: time = 0.98 !- real :: time_ini99 !- real :: xlat100 !- real :: xlon101 !- real :: wtsurf102 !- real :: wqsurf103 !- real :: restart_runoff104 !- real :: xagesno105 !- real :: qsolinp106 !- real :: zpicinp107 !-108 real :: fnday109 real :: day, daytime110 real :: day1111 real :: heure112 integer :: jour113 integer :: mois114 integer :: an115 116 !---------------------------------------------------------------------117 ! Declarations related to forcing and initial profiles118 !---------------------------------------------------------------------119 120 integer :: kmax = llm121 integer llm700,nq1,nq2122 INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000123 real timestep, frac124 real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)125 real uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)126 real ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)127 real dqtdxls(nlev_max),dqtdyls(nlev_max)128 real dqtdtls(nlev_max),thlpcar(nlev_max)129 real qprof(nlev_max,nqmx)130 131 ! integer :: forcing_type132 logical :: forcing_les = .false.133 logical :: forcing_armcu = .false.134 logical :: forcing_rico = .false.135 logical :: forcing_radconv = .false.136 logical :: forcing_toga = .false.137 logical :: forcing_twpice = .false.138 logical :: forcing_amma = .false.139 logical :: forcing_dice = .false.140 logical :: forcing_gabls4 = .false.141 142 logical :: forcing_GCM2SCM = .false.143 logical :: forcing_GCSSold = .false.144 logical :: forcing_sandu = .false.145 logical :: forcing_astex = .false.146 logical :: forcing_fire = .false.147 logical :: forcing_case = .false.148 logical :: forcing_case2 = .false.149 logical :: forcing_SCM = .false.150 integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file151 ! (cf read_tsurf1d.F)152 153 real wwww154 !vertical advection computation155 ! real d_t_z(llm), d_q_z(llm)156 ! real d_t_dyn_z(llm), dq_dyn_z(llm)157 ! real zz(llm)158 ! real zfact159 160 !flag forcings161 logical :: nudge_wind=.true.162 logical :: nudge_thermo=.false.163 logical :: cptadvw=.true.164 !=====================================================================165 ! DECLARATIONS FOR EACH CASE166 !=====================================================================167 !168 #include "1D_decl_cases.h"169 !170 !---------------------------------------------------------------------171 ! Declarations related to nudging172 !---------------------------------------------------------------------173 integer :: nudge_max174 parameter (nudge_max=9)175 integer :: inudge_RHT=1176 integer :: inudge_UV=2177 logical :: nudge(nudge_max)178 real :: t_targ(llm)179 real :: rh_targ(llm)180 real :: u_targ(llm)181 real :: v_targ(llm)182 !183 !---------------------------------------------------------------------184 ! Declarations related to vertical discretization:185 !---------------------------------------------------------------------186 real :: pzero=1.e5187 real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)188 real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)189 190 !---------------------------------------------------------------------191 ! Declarations related to variables192 !---------------------------------------------------------------------193 194 real :: phi(llm)195 real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)196 REAL rot(1, llm) ! relative vorticity, in s-1197 real :: rlat_rad(1),rlon_rad(1)198 real :: omega(llm+1),omega2(llm),rho(llm+1)199 real :: ug(llm),vg(llm),fcoriolis200 real :: sfdt, cfdt201 real :: du_phys(llm),dv_phys(llm),dt_phys(llm)202 real :: dt_dyn(llm)203 real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)204 real :: d_u_nudge(llm),d_v_nudge(llm)205 real :: du_adv(llm),dv_adv(llm)206 real :: du_age(llm),dv_age(llm)207 real :: alpha208 real :: ttt209 210 REAL, ALLOCATABLE, DIMENSION(:,:):: q211 REAL, ALLOCATABLE, DIMENSION(:,:):: dq212 REAL, ALLOCATABLE, DIMENSION(:,:):: dq_dyn213 REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv214 REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge215 ! REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv216 217 !---------------------------------------------------------------------218 ! Initialization of surface variables219 !---------------------------------------------------------------------220 real :: run_off_lic_0(1)221 real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)222 real :: tsoil(1,nsoilmx,nbsrf)223 ! real :: agesno(1,nbsrf)224 225 !---------------------------------------------------------------------226 ! Call to phyredem227 !---------------------------------------------------------------------228 logical :: ok_writedem =.true.229 real :: sollw_in = 0.230 real :: solsw_in = 0.231 232 !---------------------------------------------------------------------233 ! Call to physiq234 !---------------------------------------------------------------------235 logical :: firstcall=.true.236 logical :: lastcall=.false.237 real :: phis(1) = 0.0238 real :: dpsrf(1)239 240 !---------------------------------------------------------------------241 ! Initializations of boundary conditions242 !---------------------------------------------------------------------243 real, allocatable :: phy_nat (:) ! 0=ocean libre,1=land,2=glacier,3=banquise244 real, allocatable :: phy_alb (:) ! Albedo land only (old value condsurf_jyg=0.3)245 real, allocatable :: phy_sst (:) ! SST (will not be used; cf read_tsurf1d.F)246 real, allocatable :: phy_bil (:) ! Ne sert que pour les slab_ocean247 real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only248 real, allocatable :: phy_ice (:) ! Fraction de glace249 real, allocatable :: phy_fter(:) ! Fraction de terre250 real, allocatable :: phy_foce(:) ! Fraction de ocean251 real, allocatable :: phy_fsic(:) ! Fraction de glace252 real, allocatable :: phy_flic(:) ! Fraction de glace253 254 !---------------------------------------------------------------------255 ! Fichiers et d'autres variables256 !---------------------------------------------------------------------257 integer :: k,l,i,it=1,mxcalc258 integer :: nsrf259 integer jcode260 INTEGER read_climoz261 !262 integer :: it_end ! iteration number of the last call263 !Al1264 integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file265 data ecrit_slab_oc/-1/266 !267 ! if flag_inhib_forcing = 0, tendencies of forcing are added268 ! <> 0, tendencies of forcing are not added269 INTEGER :: flag_inhib_forcing = 0270 271 !=====================================================================272 ! INITIALIZATIONS273 !=====================================================================274 du_phys(:)=0.275 dv_phys(:)=0.276 dt_phys(:)=0.277 dt_dyn(:)=0.278 dt_cooling(:)=0.279 d_t_adv(:)=0.280 d_t_nudge(:)=0.281 d_u_nudge(:)=0.282 d_v_nudge(:)=0.283 du_adv(:)=0.284 dv_adv(:)=0.285 du_age(:)=0.286 dv_age(:)=0.287 288 ! Initialization of Common turb_forcing289 dtime_frcg = 0.290 Turb_fcg_gcssold=.false.291 hthturb_gcssold = 0.292 hqturb_gcssold = 0.293 294 295 296 297 !---------------------------------------------------------------------298 ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)299 !---------------------------------------------------------------------300 !Al1301 call conf_unicol302 !Al1 moves this gcssold var from common fcg_gcssold to303 Turb_fcg_gcssold = xTurb_fcg_gcssold304 ! --------------------------------------------------------------------305 close(1)306 !Al1307 write(*,*) 'lmdz1d.def lu => unicol.def'308 309 ! forcing_type defines the way the SCM is forced:310 !forcing_type = 0 ==> forcing_les = .true.311 ! initial profiles from file prof.inp.001312 ! no forcing by LS convergence ;313 ! surface temperature imposed ;314 ! radiative cooling may be imposed (iflag_radia=0 in physiq.def)315 !forcing_type = 1 ==> forcing_radconv = .true.316 ! idem forcing_type = 0, but the imposed radiative cooling317 ! is set to 0 (hence, if iflag_radia=0 in physiq.def,318 ! then there is no radiative cooling at all)319 !forcing_type = 2 ==> forcing_toga = .true.320 ! initial profiles from TOGA-COARE IFA files321 ! LS convergence and SST imposed from TOGA-COARE IFA files322 !forcing_type = 3 ==> forcing_GCM2SCM = .true.323 ! initial profiles from the GCM output324 ! LS convergence imposed from the GCM output325 !forcing_type = 4 ==> forcing_twpice = .true.326 ! initial profiles from TWP-ICE cdf file327 ! LS convergence, omega and SST imposed from TWP-ICE files328 !forcing_type = 5 ==> forcing_rico = .true.329 ! initial profiles from RICO files330 ! LS convergence imposed from RICO files331 !forcing_type = 6 ==> forcing_amma = .true.332 ! initial profiles from AMMA nc file333 ! LS convergence, omega and surface fluxes imposed from AMMA file334 !forcing_type = 7 ==> forcing_dice = .true.335 ! initial profiles and large scale forcings in dice_driver.nc336 ! Different stages: soil model alone, atm. model alone337 ! then both models coupled338 !forcing_type = 8 ==> forcing_gabls4 = .true.339 ! initial profiles and large scale forcings in gabls4_driver.nc340 !forcing_type >= 100 ==> forcing_case = .true.341 ! initial profiles and large scale forcings in cas.nc342 ! LS convergence, omega and SST imposed from CINDY-DYNAMO files343 ! 101=cindynamo344 ! 102=bomex345 !forcing_type >= 100 ==> forcing_case2 = .true.346 ! temporary flag while all the 1D cases are not whith the same cas.nc forcing file347 ! 103=arm_cu2 ie arm_cu with new forcing format348 ! 104=rico2 ie rico with new forcing format349 !forcing_type = 40 ==> forcing_GCSSold = .true.350 ! initial profile from GCSS file351 ! LS convergence imposed from GCSS file352 !forcing_type = 50 ==> forcing_fire = .true.353 ! forcing from fire.nc354 !forcing_type = 59 ==> forcing_sandu = .true.355 ! initial profiles from sanduref file: see prof.inp.001356 ! SST varying with time and divergence constante: see ifa_sanduref.txt file357 ! Radiation has to be computed interactively358 !forcing_type = 60 ==> forcing_astex = .true.359 ! initial profiles from file: see prof.inp.001360 ! SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file361 ! Radiation has to be computed interactively362 !forcing_type = 61 ==> forcing_armcu = .true.363 ! initial profiles from file: see prof.inp.001364 ! sensible and latent heat flux imposed: see ifa_arm_cu_1.txt365 ! large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt366 ! use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s367 ! Radiation to be switched off368 !369 if (forcing_type <=0) THEN370 forcing_les = .true.371 elseif (forcing_type .eq.1) THEN372 forcing_radconv = .true.373 elseif (forcing_type .eq.2) THEN374 forcing_toga = .true.375 elseif (forcing_type .eq.3) THEN376 forcing_GCM2SCM = .true.377 elseif (forcing_type .eq.4) THEN378 forcing_twpice = .true.379 elseif (forcing_type .eq.5) THEN380 forcing_rico = .true.381 elseif (forcing_type .eq.6) THEN382 forcing_amma = .true.383 elseif (forcing_type .eq.7) THEN384 forcing_dice = .true.385 elseif (forcing_type .eq.8) THEN386 forcing_gabls4 = .true.387 elseif (forcing_type .eq.101) THEN ! Cindynamo starts 1-10-2011 0h388 forcing_case = .true.389 year_ini_cas=2011390 mth_ini_cas=10391 day_deb=1392 heure_ini_cas=0.393 pdt_cas=3*3600. ! forcing frequency394 elseif (forcing_type .eq.102) THEN ! Bomex starts 24-6-1969 0h395 forcing_case = .true.396 year_ini_cas=1969397 mth_ini_cas=6398 day_deb=24399 heure_ini_cas=0.400 pdt_cas=1800. ! forcing frequency401 elseif (forcing_type .eq.103) THEN ! Arm_cu starts 21-6-1997 11h30402 forcing_case2 = .true.403 year_ini_cas=1997404 mth_ini_cas=6405 day_deb=21406 heure_ini_cas=11.5407 pdt_cas=1800. ! forcing frequency408 elseif (forcing_type .eq.104) THEN ! rico starts 16-12-2004 0h409 forcing_case2 = .true.410 year_ini_cas=2004411 mth_ini_cas=12412 day_deb=16413 heure_ini_cas=0.414 pdt_cas=1800. ! forcing frequency415 elseif (forcing_type .eq.105) THEN ! bomex starts 16-12-2004 0h416 forcing_case2 = .true.417 year_ini_cas=1969418 mth_ini_cas=6419 day_deb=24420 heure_ini_cas=0.421 pdt_cas=1800. ! forcing frequency422 elseif (forcing_type .eq.106) THEN ! ayotte_24SC starts 6-11-1992 0h423 forcing_case2 = .true.424 year_ini_cas=1992425 mth_ini_cas=11426 day_deb=6427 heure_ini_cas=10.428 pdt_cas=86400. ! forcing frequency429 elseif (forcing_type .eq.113) THEN ! Arm_cu starts 21-6-1997 11h30430 forcing_SCM = .true.431 year_ini_cas=1997432 mth_ini_cas=6433 day_deb=21434 heure_ini_cas=11.5435 pdt_cas=1800. ! forcing frequency436 elseif (forcing_type .eq.40) THEN437 forcing_GCSSold = .true.438 elseif (forcing_type .eq.50) THEN439 forcing_fire = .true.440 elseif (forcing_type .eq.59) THEN441 forcing_sandu = .true.442 elseif (forcing_type .eq.60) THEN443 forcing_astex = .true.444 elseif (forcing_type .eq.61) THEN445 forcing_armcu = .true.446 IF(llm.NE.19.AND.llm.NE.40) stop 'Erreur nombre de niveaux !!'447 else448 write (*,*) 'ERROR : unknown forcing_type ', forcing_type449 stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'450 ENDIF451 print*,"forcing type=",forcing_type452 453 ! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time454 ! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature455 ! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F456 ! through the common sst_forcing.457 458 type_ts_forcing = 0459 if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice) &460 & type_ts_forcing = 1461 !462 ! Initialization of the logical switch for nudging463 jcode = iflag_nudge464 do i = 1,nudge_max465 nudge(i) = mod(jcode,10) .ge. 1466 jcode = jcode/10467 enddo468 !---------------------------------------------------------------------469 ! Definition of the run470 !---------------------------------------------------------------------471 472 call conf_gcm( 99, .TRUE. )473 474 !-----------------------------------------------------------------------475 allocate( phy_nat (year_len)) ! 0=ocean libre,1=land,2=glacier,3=banquise476 phy_nat(:)=0.0477 allocate( phy_alb (year_len)) ! Albedo land only (old value condsurf_jyg=0.3)478 allocate( phy_sst (year_len)) ! SST (will not be used; cf read_tsurf1d.F)479 allocate( phy_bil (year_len)) ! Ne sert que pour les slab_ocean480 phy_bil(:)=1.0481 allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only482 allocate( phy_ice (year_len)) ! Fraction de glace483 phy_ice(:)=0.0484 allocate( phy_fter(year_len)) ! Fraction de terre485 phy_fter(:)=0.0486 allocate( phy_foce(year_len)) ! Fraction de ocean487 phy_foce(:)=0.0488 allocate( phy_fsic(year_len)) ! Fraction de glace489 phy_fsic(:)=0.0490 allocate( phy_flic(year_len)) ! Fraction de glace491 phy_flic(:)=0.0492 !-----------------------------------------------------------------------493 ! Choix du calendrier494 ! -------------------495 496 ! calend = 'earth_365d'497 if (calend == 'earth_360d') then498 call ioconf_calendar('360d')499 write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'500 else if (calend == 'earth_365d') then501 call ioconf_calendar('noleap')502 write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'503 else if (calend == 'earth_366d') then504 call ioconf_calendar('all_leap')505 write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'506 else if (calend == 'gregorian') then507 stop 'gregorian calend should not be used by normal user'508 call ioconf_calendar('gregorian') ! not to be used by normal users509 write(*,*)'CALENDRIER CHOISI: Gregorien'510 else511 write (*,*) 'ERROR : unknown calendar ', calend512 stop 'calend should be 360d,earth_365d,earth_366d,gregorian'513 endif514 !-----------------------------------------------------------------------515 !516 !c Date :517 ! La date est supposee donnee sous la forme [annee, numero du jour dans518 ! l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.519 ! On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].520 ! Le numero du jour est dans "day". L heure est traitee separement.521 ! La date complete est dans "daytime" (l'unite est le jour).522 if (nday>0) then523 fnday=nday524 else525 fnday=-nday/float(day_step)526 endif527 print *,'fnday=',fnday528 ! start_time doit etre en FRACTION DE JOUR529 start_time=time_ini/24.530 531 ! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)532 IF(forcing_type .EQ. 61) fnday=53100./86400.533 IF(forcing_type .EQ. 103) fnday=53100./86400.534 ! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)535 IF(forcing_type .EQ. 6) fnday=64800./86400.536 ! IF(forcing_type .EQ. 6) fnday=50400./86400.537 IF(forcing_type .EQ. 8 ) fnday=129600./86400.538 annee_ref = anneeref539 mois = 1540 day_ref = dayref541 heure = 0.542 itau_dyn = 0543 itau_phy = 0544 call ymds2ju(annee_ref,mois,day_ref,heure,day)545 day_ini = int(day)546 day_end = day_ini + int(fnday)547 548 IF (forcing_type .eq.2) THEN549 ! Convert the initial date of Toga-Coare to Julian day550 call ymds2ju &551 & (year_ini_toga,mth_ini_toga,day_ini_toga,heure,day_ju_ini_toga)552 553 ELSEIF (forcing_type .eq.4) THEN554 ! Convert the initial date of TWPICE to Julian day555 call ymds2ju &556 & (year_ini_twpi,mth_ini_twpi,day_ini_twpi,heure_ini_twpi &557 & ,day_ju_ini_twpi)558 ELSEIF (forcing_type .eq.6) THEN559 ! Convert the initial date of AMMA to Julian day560 call ymds2ju &561 & (year_ini_amma,mth_ini_amma,day_ini_amma,heure_ini_amma &562 & ,day_ju_ini_amma)563 ELSEIF (forcing_type .eq.7) THEN564 ! Convert the initial date of DICE to Julian day565 call ymds2ju &566 & (year_ini_dice,mth_ini_dice,day_ini_dice,heure_ini_dice &567 & ,day_ju_ini_dice)568 ELSEIF (forcing_type .eq.8 ) THEN569 ! Convert the initial date of GABLS4 to Julian day570 call ymds2ju &571 & (year_ini_gabls4,mth_ini_gabls4,day_ini_gabls4,heure_ini_gabls4 &572 & ,day_ju_ini_gabls4)573 ELSEIF (forcing_type .gt.100) THEN574 ! Convert the initial date to Julian day575 day_ini_cas=day_deb576 print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas577 call ymds2ju &578 & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600 &579 & ,day_ju_ini_cas)580 print*,'time case 2',day_ini_cas,day_ju_ini_cas581 ELSEIF (forcing_type .eq.59) THEN582 ! Convert the initial date of Sandu case to Julian day583 call ymds2ju &584 & (year_ini_sandu,mth_ini_sandu,day_ini_sandu, &585 & time_ini*3600.,day_ju_ini_sandu)586 587 ELSEIF (forcing_type .eq.60) THEN588 ! Convert the initial date of Astex case to Julian day589 call ymds2ju &590 & (year_ini_astex,mth_ini_astex,day_ini_astex, &591 & time_ini*3600.,day_ju_ini_astex)592 593 ELSEIF (forcing_type .eq.61) THEN594 ! Convert the initial date of Arm_cu case to Julian day595 call ymds2ju &596 & (year_ini_armcu,mth_ini_armcu,day_ini_armcu,heure_ini_armcu &597 & ,day_ju_ini_armcu)598 ENDIF599 600 IF (forcing_type .gt.100) THEN601 daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation602 ELSE603 daytime = day + time_ini/24. ! 1st day and initial time of the simulation604 ENDIF605 ! Print out the actual date of the beginning of the simulation :606 call ju2ymds(daytime,year_print, month_print,day_print,sec_print)607 print *,' Time of beginning : ', &608 & year_print, month_print, day_print, sec_print609 610 !---------------------------------------------------------------------611 ! Initialization of dimensions, geometry and initial state612 !---------------------------------------------------------------------613 ! call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq614 ! but we still need to initialize dimphy module (klon,klev,etc.) here.615 call init_dimphy1D(1,llm)616 call suphel617 call infotrac_init618 619 if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'620 allocate(q(llm,nqtot)) ; q(:,:)=0.621 allocate(dq(llm,nqtot))622 allocate(dq_dyn(llm,nqtot))623 allocate(d_q_adv(llm,nqtot))624 allocate(d_q_nudge(llm,nqtot))625 ! allocate(d_th_adv(llm))626 627 q(:,:) = 0.628 dq(:,:) = 0.629 dq_dyn(:,:) = 0.630 d_q_adv(:,:) = 0.631 d_q_nudge(:,:) = 0.632 633 !634 ! No ozone climatology need be read in this pre-initialization635 ! (phys_state_var_init is called again in physiq)636 read_climoz = 0637 !638 call phys_state_var_init(read_climoz)639 640 if (ngrid.ne.klon) then641 print*,'stop in inifis'642 print*,'Probleme de dimensions :'643 print*,'ngrid = ',ngrid644 print*,'klon = ',klon645 stop646 endif647 !!!=====================================================================648 !!! Feedback forcing values for Gateaux differentiation (al1)649 !!!=====================================================================650 !!! Surface Planck forcing bracketing call radiation651 !! surf_Planck = 0.652 !! surf_Conv = 0.653 !! write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv654 !!! a mettre dans le lmdz1d.def ou autre655 !!656 !!657 qsol = qsolinp658 qsurf = fq_sat(tsurf,psurf/100.)659 day1= day_ini660 time=daytime-day661 ts_toga(1)=tsurf ! needed by read_tsurf1d.F662 rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf))663 664 !665 !! mpl et jyg le 22/08/2012 :666 !! pour que les cas a flux de surface imposes marchent667 IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN668 fsens=-wtsurf*rcpd*rho(1)669 flat=-wqsurf*rlvtt*rho(1)670 print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf671 ENDIF672 print*,'Flux sol ',fsens,flat673 !! ok_flux_surf=.false.674 !! fsens=-wtsurf*rcpd*rho(1)675 !! flat=-wqsurf*rlvtt*rho(1)676 !!!!677 678 ! Vertical discretization and pressure levels at half and mid levels:679 680 pa = 5e4681 !! preff= 1.01325e5682 preff = psurf683 IF (ok_old_disvert) THEN684 call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)685 print *,'On utilise disvert0'686 aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))687 bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))688 scaleheight=8.689 pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)690 ELSE691 call disvert()692 print *,'On utilise disvert'693 ! Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012694 ! Dans ce cas, on lit ap,bp dans le fichier hybrid.txt695 ENDIF696 697 sig_s=presnivs/preff698 plev =ap+bp*psurf699 play = 0.5*(plev(1:llm)+plev(2:llm+1))700 zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles701 702 IF (forcing_type .eq. 59) THEN703 ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m704 write(*,*) '***********************'705 do l = 1, llm706 write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)707 if (trouve_700 .and. play(l).le.70000) then708 llm700=l709 print *,'llm700,play=',llm700,play(l)/100.710 trouve_700= .false.711 endif712 enddo713 write(*,*) '***********************'714 ENDIF715 716 !717 !=====================================================================718 ! EVENTUALLY, READ FORCING DATA :719 !=====================================================================720 721 #include "1D_read_forc_cases.h"722 723 if (forcing_GCM2SCM) then724 write (*,*) 'forcing_GCM2SCM not yet implemented'725 stop 'in initialization'726 endif ! forcing_GCM2SCM727 728 print*,'mxcalc=',mxcalc729 ! print*,'zlay=',zlay(mxcalc)730 print*,'play=',play(mxcalc)731 732 !Al1 pour SST forced, appell?? depuis ocean_forced_noice733 ts_cur = tsurf ! SST used in read_tsurf1d734 !=====================================================================735 ! Initialisation de la physique :736 !=====================================================================737 738 ! Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F739 !740 ! day_step, iphysiq lus dans gcm.def ci-dessus741 ! timestep: calcule ci-dessous from rday et day_step742 ! ngrid=1743 ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension744 ! rday: defini dans suphel.F (86400.)745 ! day_ini: lu dans run.def (dayref)746 ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)747 ! airefi,zcufi,zcvfi initialises au debut de ce programme748 ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F749 day_step = float(nsplit_phys)*day_step/float(iphysiq)750 write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'751 timestep =rday/day_step752 dtime_frcg = timestep753 !754 zcufi=airefi755 zcvfi=airefi756 !757 rlat_rad(1)=xlat*rpi/180.758 rlon_rad(1)=xlon*rpi/180.759 760 ! iniphysiq will call iniaqua who needs year_len from phys_cal_mod761 year_len_phys_cal_mod=year_len762 763 ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,764 ! e.g. for cell boundaries, which are meaningless in 1D; so pad these765 ! with '0.' when necessary766 call iniphysiq(iim,jjm,llm, &767 1,comm_lmdz, &768 rday,day_ini,timestep, &769 (/rlat_rad(1),0./),(/0./), &770 (/0.,0./),(/rlon_rad(1),0./), &771 (/ (/airefi,0./),(/0.,0./) /), &772 (/zcufi,0.,0.,0./), &773 (/zcvfi,0./), &774 ra,rg,rd,rcpd,1)775 print*,'apres iniphysiq'776 777 ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:778 co2_ppm= 330.0779 solaire=1370.0780 781 ! Ecriture du startphy avant le premier appel a la physique.782 ! On le met juste avant pour avoir acces a tous les champs783 784 if (ok_writedem) then785 786 !--------------------------------------------------------------------------787 ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)788 ! need : qsol fder snow qsurf evap rugos agesno ftsoil789 !--------------------------------------------------------------------------790 791 type_ocean = "force"792 run_off_lic_0(1) = restart_runoff793 call fonte_neige_init(run_off_lic_0)794 795 fder=0.796 snsrf(1,:)=snowmass ! masse de neige des sous surface797 qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface798 fevap=0.799 z0m(1,:)=rugos ! couverture de neige des sous surface800 z0h(1,:)=rugosh ! couverture de neige des sous surface801 agesno = xagesno802 tsoil(:,:,:)=tsurf803 !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)804 ! tsoil(1,1,1)=299.18805 ! tsoil(1,2,1)=300.08806 ! tsoil(1,3,1)=301.88807 ! tsoil(1,4,1)=305.48808 ! tsoil(1,5,1)=308.00809 ! tsoil(1,6,1)=308.00810 ! tsoil(1,7,1)=308.00811 ! tsoil(1,8,1)=308.00812 ! tsoil(1,9,1)=308.00813 ! tsoil(1,10,1)=308.00814 ! tsoil(1,11,1)=308.00815 !-----------------------------------------------------------------------816 call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)817 818 !------------------ prepare limit conditions for limit.nc -----------------819 !-- Ocean force820 821 print*,'avant phyredem'822 pctsrf(1,:)=0.823 if (nat_surf.eq.0.) then824 pctsrf(1,is_oce)=1.825 pctsrf(1,is_ter)=0.826 pctsrf(1,is_lic)=0.827 pctsrf(1,is_sic)=0.828 else if (nat_surf .eq. 1) then829 pctsrf(1,is_oce)=0.830 pctsrf(1,is_ter)=1.831 pctsrf(1,is_lic)=0.832 pctsrf(1,is_sic)=0.833 else if (nat_surf .eq. 2) then834 pctsrf(1,is_oce)=0.835 pctsrf(1,is_ter)=0.836 pctsrf(1,is_lic)=1.837 pctsrf(1,is_sic)=0.838 else if (nat_surf .eq. 3) then839 pctsrf(1,is_oce)=0.840 pctsrf(1,is_ter)=0.841 pctsrf(1,is_lic)=0.842 pctsrf(1,is_sic)=1.843 844 end if845 846 847 print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf &848 & ,pctsrf(1,is_oce),pctsrf(1,is_ter)849 850 zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)851 zpic = zpicinp852 ftsol=tsurf853 nsw=6 ! on met le nb de bandes SW=6, pour initialiser854 ! 6 albedo, mais on peut quand meme tourner avec855 ! moins. Seules les 2 ou 4 premiers seront lus856 falb_dir=albedo857 falb_dif=albedo858 rugoro=rugos859 t_ancien(1,:)=temp(:)860 q_ancien(1,:)=q(:,1)861 ql_ancien = 0.862 qs_ancien = 0.863 prlw_ancien = 0.864 prsw_ancien = 0.865 prw_ancien = 0.866 !jyg<867 !! pbl_tke(:,:,:)=1.e-8868 pbl_tke(:,:,:)=0.869 pbl_tke(:,2,:)=1.e-2870 PRINT *, ' pbl_tke dans lmdz1d '871 if (prt_level .ge. 5) then872 DO nsrf = 1,4873 PRINT *,'pbl_tke(1,:,',nsrf,') ',pbl_tke(1,:,nsrf)874 ENDDO875 end if876 877 !>jyg878 879 rain_fall=0.880 snow_fall=0.881 solsw=0.882 sollw=0.883 sollwdown=rsigma*tsurf**4884 radsol=0.885 rnebcon=0.886 ratqs=0.887 clwcon=0.888 zmax0 = 0.889 zmea=0.890 zstd=0.891 zsig=0.892 zgam=0.893 zval=0.894 zthe=0.895 sig1=0.896 w01=0.897 wake_cstar = 0.898 wake_deltaq = 0.899 wake_deltat = 0.900 wake_delta_pbl_TKE(:,:,:) = 0.901 delta_tsurf = 0.902 wake_fip = 0.903 wake_pe = 0.904 wake_s = 0.905 wake_dens = 0.906 ale_bl = 0.907 ale_bl_trig = 0.908 alp_bl = 0.909 IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.910 IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.911 entr_therm = 0.912 detr_therm = 0.913 f0 = 0.914 fm_therm = 0.915 u_ancien(1,:)=u(:)916 v_ancien(1,:)=v(:)917 918 !------------------------------------------------------------------------919 ! Make file containing restart for the physics (startphy.nc)920 !921 ! NB: List of the variables to be written by phyredem (via put_field):922 ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)923 ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)924 ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)925 ! radsol,solsw,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)926 ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro927 ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)928 ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01929 ! wake_deltat,wake_deltaq,wake_s,wake_dens,wake_cstar,930 ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)931 !932 ! NB2: The content of the startphy.nc file depends on some flags defined in933 ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have934 ! to be set at some arbitratry convenient values.935 !------------------------------------------------------------------------936 !Al1 =============== restart option ==========================937 if (.not.restart) then938 iflag_pbl = 5939 call phyredem ("startphy.nc")940 else941 ! (desallocations)942 print*,'callin surf final'943 call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)944 print*,'after surf final'945 CALL fonte_neige_final(run_off_lic_0)946 endif947 948 ok_writedem=.false.949 print*,'apres phyredem'950 951 endif ! ok_writedem952 953 !------------------------------------------------------------------------954 ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***955 ! --------------------------------------------------956 ! NB: List of the variables to be written in limit.nc957 ! (by writelim.F, subroutine of 1DUTILS.h):958 ! phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,959 ! phy_fter,phy_foce,phy_flic,phy_fsic)960 !------------------------------------------------------------------------961 do i=1,year_len962 phy_nat(i) = nat_surf963 phy_alb(i) = albedo964 phy_sst(i) = tsurf ! read_tsurf1d will be used instead965 phy_rug(i) = rugos966 phy_fter(i) = pctsrf(1,is_ter)967 phy_foce(i) = pctsrf(1,is_oce)968 phy_fsic(i) = pctsrf(1,is_sic)969 phy_flic(i) = pctsrf(1,is_lic)970 enddo971 972 ! fabrication de limit.nc973 call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug, &974 & phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)975 976 977 call phys_state_var_end978 !Al1979 if (restart) then980 print*,'call to restart dyn 1d'981 Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs, &982 & u,v,temp,q,omega2)983 984 print*,'fnday,annee_ref,day_ref,day_ini', &985 & fnday,annee_ref,day_ref,day_ini986 !** call ymds2ju(annee_ref,mois,day_ini,heure,day)987 day = day_ini988 day_end = day_ini + nday989 daytime = day + time_ini/24. ! 1st day and initial time of the simulation990 991 ! Print out the actual date of the beginning of the simulation :992 call ju2ymds(daytime, an, mois, jour, heure)993 print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.994 995 day = int(daytime)996 time=daytime-day997 998 print*,'****** intialised fields from restart1dyn *******'999 print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'1000 print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'1001 print*,temp(1),q(1,1),u(1),v(1),plev(1),phis1002 ! raz for safety1003 do l=1,llm1004 dq_dyn(l,1) = 0.1005 enddo1006 endif1007 !Al1 ================ end restart =================================1008 IF (ecrit_slab_oc.eq.1) then1009 open(97,file='div_slab.dat',STATUS='UNKNOWN')1010 elseif (ecrit_slab_oc.eq.0) then1011 open(97,file='div_slab.dat',STATUS='OLD')1012 endif1013 !1014 !---------------------------------------------------------------------1015 ! Initialize target profile for RHT nudging if needed1016 !---------------------------------------------------------------------1017 if (nudge(inudge_RHT)) then1018 call nudge_RHT_init(plev,play,temp,q(:,1),t_targ,rh_targ)1019 endif1020 if (nudge(inudge_UV)) then1021 call nudge_UV_init(plev,play,u,v,u_targ,v_targ)1022 endif1023 !1024 !=====================================================================1025 CALL iophys_ini1026 ! START OF THE TEMPORAL LOOP :1027 !=====================================================================1028 1029 it_end = nint(fnday*day_step)1030 !test JLD it_end = 101031 do while(it.le.it_end)1032 1033 if (prt_level.ge.1) then1034 print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=', &1035 & it,day,time,it_end,day_step1036 print*,'PAS DE TEMPS ',timestep1037 endif1038 !Al1 demande de restartphy.nc1039 if (it.eq.it_end) lastcall=.True.1040 1041 !---------------------------------------------------------------------1042 ! Interpolation of forcings in time and onto model levels1043 !---------------------------------------------------------------------1044 1045 #include "1D_interp_cases.h"1046 1047 if (forcing_GCM2SCM) then1048 write (*,*) 'forcing_GCM2SCM not yet implemented'1049 stop 'in time loop'1050 endif ! forcing_GCM2SCM1051 1052 !---------------------------------------------------------------------1053 ! Geopotential :1054 !---------------------------------------------------------------------1055 1056 phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))1057 do l = 1, llm-11058 phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))* &1059 & (play(l)-play(l+1))/(play(l)+play(l+1))1060 enddo1061 1062 !---------------------------------------------------------------------1063 ! Listing output for debug prt_level>=11064 !---------------------------------------------------------------------1065 if (prt_level>=1) then1066 print *,' avant physiq : -------- day time ',day,time1067 write(*,*) 'firstcall,lastcall,phis', &1068 & firstcall,lastcall,phis1069 end if1070 if (prt_level>=5) then1071 write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l', &1072 & 'presniv','plev','play','phi'1073 write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l, &1074 & presnivs(l),plev(l),play(l),phi(l),l=1,llm)1075 write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l', &1076 & 'presniv','u','v','temp','q1','q2','omega2'1077 write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l, &1078 & presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)1079 endif1080 1081 !---------------------------------------------------------------------1082 ! Call physiq :1083 !---------------------------------------------------------------------1084 call physiq(ngrid,llm, &1085 firstcall,lastcall,timestep, &1086 plev,play,phi,phis,presnivs, &1087 u,v, rot, temp,q,omega2, &1088 du_phys,dv_phys,dt_phys,dq,dpsrf)1089 firstcall=.false.1090 1091 !---------------------------------------------------------------------1092 ! Listing output for debug1093 !---------------------------------------------------------------------1094 if (prt_level>=5) then1095 write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l', &1096 & 'presniv','plev','play','phi'1097 write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l, &1098 & presnivs(l),plev(l),play(l),phi(l),l=1,llm)1099 write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l', &1100 & 'presniv','u','v','temp','q1','q2','omega2'1101 write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l, &1102 & presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)1103 write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l', &1104 & 'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'1105 write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l, &1106 & presnivs(l),86400*du_phys(l),86400*dv_phys(l), &1107 & 86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)1108 write(*,*) 'dpsrf',dpsrf1109 endif1110 !---------------------------------------------------------------------1111 ! Add physical tendencies :1112 !---------------------------------------------------------------------1113 1114 fcoriolis=2.*sin(rpi*xlat/180.)*romega1115 if (forcing_radconv .or. forcing_fire) then1116 fcoriolis=0.01117 dt_cooling=0.01118 d_t_adv=0.01119 d_q_adv=0.01120 endif1121 ! print*, 'calcul de fcoriolis ', fcoriolis1122 1123 if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice &1124 & .or.forcing_amma .or. forcing_type.eq.101) then1125 fcoriolis=0.0 ; ug=0. ; vg=0.1126 endif1127 1128 if(forcing_rico) then1129 dt_cooling=0.1130 endif1131 1132 !CRio:Attention modif sp??cifique cas de Caroline1133 if (forcing_type==-1) then1134 fcoriolis=0.1135 !Nudging1136 1137 !on calcule dt_cooling1138 do l=1,llm1139 if (play(l).ge.20000.) then1140 dt_cooling(l)=-1.5/86400.1141 elseif ((play(l).ge.10000.).and.((play(l).lt.20000.))) then1142 dt_cooling(l)=-1.5/86400.*(play(l)-10000.)/(10000.)-1./86400.*(20000.-play(l))/10000.*(temp(l)-200.)1143 else1144 dt_cooling(l)=-1.*(temp(l)-200.)/86400.1145 endif1146 enddo1147 1148 endif1149 !RC1150 if (forcing_sandu) then1151 ug(1:llm)=u_mod(1:llm)1152 vg(1:llm)=v_mod(1:llm)1153 endif1154 1155 IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &1156 fcoriolis, xlat,mxcalc1157 1158 ! print *,'u-ug=',u-ug1159 1160 !!!!!!!!!!!!!!!!!!!!!!!!1161 ! Geostrophic wind1162 ! Le calcul ci dessous est insuffisamment precis1163 ! du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))1164 ! dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))1165 !!!!!!!!!!!!!!!!!!!!!!!!1166 sfdt = sin(0.5*fcoriolis*timestep)1167 cfdt = cos(0.5*fcoriolis*timestep)1168 ! print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep1169 !1170 du_age(1:mxcalc)= -2.*sfdt/timestep* &1171 & (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) - &1172 & cfdt*(v(1:mxcalc)-vg(1:mxcalc)) )1173 !! : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))1174 !1175 dv_age(1:mxcalc)= -2.*sfdt/timestep* &1176 & (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) + &1177 & sfdt*(v(1:mxcalc)-vg(1:mxcalc)) )1178 !! : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))1179 !1180 !!!!!!!!!!!!!!!!!!!!!!!!1181 ! Nudging1182 !!!!!!!!!!!!!!!!!!!!!!!!1183 d_t_nudge(:) = 0.1184 d_q_nudge(:,:) = 0.1185 d_u_nudge(:) = 0.1186 d_v_nudge(:) = 0.1187 if (nudge(inudge_RHT)) then1188 call nudge_RHT(timestep,plev,play,t_targ,rh_targ,temp,q(:,1), &1189 & d_t_nudge,d_q_nudge(:,1))1190 endif1191 if (nudge(inudge_UV)) then1192 call nudge_UV(timestep,plev,play,u_targ,v_targ,u,v, &1193 & d_u_nudge,d_v_nudge)1194 endif1195 !1196 if (forcing_fire) THEN1197 1198 !let ww=if ( alt le 1100 ) then alt*-0.00001 else 01199 !let wt=if ( alt le 1100 ) then min( -3.75e-5 , -7.5e-8*alt) else 01200 !let wq=if ( alt le 1100 ) then max( 1.5e-8 , 3e-11*alt) else 01201 d_t_adv=0.1202 d_q_adv=0.1203 teta=temp*(pzero/play)**rkappa1204 d_t_adv=0.1205 d_q_adv=0.1206 do l=2,llm-11207 if (zlay(l)<=1100) then1208 wwww=-0.00001*zlay(l)1209 d_t_adv(l)=-wwww*(teta(l)-teta(l+1))/(zlay(l)-zlay(l+1)) /(pzero/play(l))**rkappa1210 d_q_adv(l,1:2)=-wwww*(q(l,1:2)-q(l+1,1:2))/(zlay(l)-zlay(l+1))1211 d_t_adv(l)=d_t_adv(l)+min(-3.75e-5 , -7.5e-8*zlay(l))1212 d_q_adv(l,1)=d_q_adv(l,1)+max( 1.5e-8 , 3e-11*zlay(l))1213 endif1214 enddo1215 1216 endif1217 1218 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1219 ! call writefield_phy('dv_age' ,dv_age,llm)1220 ! call writefield_phy('du_age' ,du_age,llm)1221 ! call writefield_phy('du_phys' ,du_phys,llm)1222 ! call writefield_phy('u_tend' ,u,llm)1223 ! call writefield_phy('u_g' ,ug,llm)1224 !1225 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!1226 !! Increment state variables1227 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!1228 IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added1229 1230 ! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h1231 ! au dessus de 700hpa, on relaxe vers les profils initiaux1232 if (forcing_sandu .OR. forcing_astex) then1233 #include "1D_nudge_sandu_astex.h"1234 else1235 u(1:mxcalc)=u(1:mxcalc) + timestep*( &1236 & du_phys(1:mxcalc) &1237 & +du_age(1:mxcalc)+du_adv(1:mxcalc) &1238 & +d_u_nudge(1:mxcalc) )1239 v(1:mxcalc)=v(1:mxcalc) + timestep*( &1240 & dv_phys(1:mxcalc) &1241 & +dv_age(1:mxcalc)+dv_adv(1:mxcalc) &1242 & +d_v_nudge(1:mxcalc) )1243 q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*( &1244 & dq(1:mxcalc,:) &1245 & +d_q_adv(1:mxcalc,:) &1246 & +d_q_nudge(1:mxcalc,:) )1247 1248 if (prt_level.ge.3) then1249 print *, &1250 & 'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ', &1251 & temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)1252 print* ,'dv_phys=',dv_phys1253 print* ,'dv_age=',dv_age1254 print* ,'dv_adv=',dv_adv1255 print* ,'d_v_nudge=',d_v_nudge1256 print*, v1257 print*, vg1258 endif1259 1260 temp(1:mxcalc)=temp(1:mxcalc)+timestep*( &1261 & dt_phys(1:mxcalc) &1262 & +d_t_adv(1:mxcalc) &1263 & +d_t_nudge(1:mxcalc) &1264 & +dt_cooling(1:mxcalc)) ! Taux de chauffage ou refroid.1265 1266 endif ! forcing_sandu or forcing_astex1267 1268 teta=temp*(pzero/play)**rkappa1269 !1270 !---------------------------------------------------------------------1271 ! Nudge soil temperature if requested1272 !---------------------------------------------------------------------1273 1274 IF (nudge_tsoil .AND. .NOT. lastcall) THEN1275 ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:) &1276 & -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)1277 ENDIF1278 1279 !---------------------------------------------------------------------1280 ! Add large-scale tendencies (advection, etc) :1281 !---------------------------------------------------------------------1282 1283 !cc nrlmd1284 !cc tmpvar=teta1285 !cc call advect_vert(llm,omega,timestep,tmpvar,plev)1286 !cc1287 !cc teta(1:mxcalc)=tmpvar(1:mxcalc)1288 !cc tmpvar(:)=q(:,1)1289 !cc call advect_vert(llm,omega,timestep,tmpvar,plev)1290 !cc q(1:mxcalc,1)=tmpvar(1:mxcalc)1291 !cc tmpvar(:)=q(:,2)1292 !cc call advect_vert(llm,omega,timestep,tmpvar,plev)1293 !cc q(1:mxcalc,2)=tmpvar(1:mxcalc)1294 1295 END IF ! end if tendency of tendency should be added1296 1297 !---------------------------------------------------------------------1298 ! Air temperature :1299 !---------------------------------------------------------------------1300 if (lastcall) then1301 print*,'Pas de temps final ',it1302 call ju2ymds(daytime, an, mois, jour, heure)1303 print*,'a la date : a m j h',an, mois, jour ,heure/3600.1304 endif1305 1306 ! incremente day time1307 ! print*,'daytime bef',daytime,1./day_step1308 daytime = daytime+1./day_step1309 !Al1dbg1310 day = int(daytime+0.1/day_step)1311 ! time = max(daytime-day,0.0)1312 !Al1&jyg: correction de bug1313 !cc time = real(mod(it,day_step))/day_step1314 time = time_ini/24.+real(mod(it,day_step))/day_step1315 ! print*,'daytime nxt time',daytime,time1316 it=it+11317 1318 enddo1319 1320 !Al11321 if (ecrit_slab_oc.ne.-1) close(97)1322 1323 !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)1324 ! -------------------------------------1325 call dyn1dredem("restart1dyn.nc", &1326 & plev,play,phi,phis,presnivs, &1327 & u,v,temp,q,omega2)1328 1329 CALL abort_gcm ('lmdz1d ','The End ',0)1330 1331 end1332 27 1333 28 #include "1DUTILS.h" -
LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.F90
r3538 r3541 320 320 321 321 #include "netcdf.inc" 322 #include "date_cas.h" 322 323 323 324 INTEGER nid,rid,ierr 324 INTEGER ii,jj 325 INTEGER ii,jj,timeid 326 REAL, ALLOCATABLE :: time_val(:) 325 327 326 328 print*,'ON EST VRAIMENT LA' … … 349 351 print*,'OK2 read2: nid,rid,lat',nid,rid,jj 350 352 !....................................................................... 351 ierr=NF_INQ_DIMID(nid,' nlev',rid)353 ierr=NF_INQ_DIMID(nid,'lev',rid) 352 354 IF (ierr.NE.NF_NOERR) THEN 353 355 print*, 'Oh probleme lecture dimension nlev' … … 355 357 ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas) 356 358 print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas 359 IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 1000 )) THEN 360 print*,'Valeur de nlev_cas peu probable' 361 STOP 362 ENDIF 357 363 !....................................................................... 358 364 ierr=NF_INQ_DIMID(nid,'time',rid) … … 363 369 ierr=NF_INQ_DIMLEN(nid,rid,nt_cas) 364 370 print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas 371 ! Lecture de l'axe des temps 372 print*,'LECTURE DU TEMPS' 373 ierr=NF_INQ_VARID(nid,'time',timeid) 374 if(ierr/=NF_NOERR) then 375 print *,'Variable time manquante dans cas.nc:' 376 ierr=NF_NOERR 377 else 378 allocate(time_val(nt_cas)) 379 #ifdef NC_DOUBLE 380 ierr = NF_GET_VAR_DOUBLE(nid,timeid,time_val) 381 #else 382 ierr = NF_GET_VAR_REAL(nid,timeid,time_val) 383 #endif 384 if(ierr/=NF_NOERR) then 385 print *,'Pb a la lecture de time cas.nc: ' 386 endif 387 endif 388 IF (nt_cas>1) THEN 389 pdt_cas=time_val(2)-time_val(1) 390 ELSE 391 pdt_cas=0. 392 ENDIF 393 365 394 366 395 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 949 978 !----------------------------------------------------------------------- 950 979 select case(i) 951 952 980 !case(1) ; ap=apbp ! donnees indexees en nlevel+1 981 ! case(2) ; bp=apbp 953 982 case(3) ; zzh=apbp 954 983 case(4) ; pph=apbp
Note: See TracChangeset
for help on using the changeset viewer.
