Changeset 3541 for LMDZ6/trunk/libf


Ignore:
Timestamp:
Jul 3, 2019, 2:40:01 PM (5 years ago)
Author:
fhourdin
Message:

Gros nettoyage en cours sur le 1D.
Le nouveau lmdz1d.F90 est une coquille vide qui choisit entre
old_lmdz1d.F90 (l'ancien lmdz1d.F90) et scm.F90 (le nouveau au format standard).
Plusieur fichiers sont renommés old_truc, le truc étant au format standard,
nettoyé des anciens formats.
Le 1DUTILS.h est lui même séparé entre des routines génériques venant remplacer
notamment des routines de dyn3d (la vocation d'origine de 1DUTILS.h) et
les routiles de lecture spécifiques mises dans old_1DUTILS.h
On perdra un peu de l'utilister de svn au moment de cette grosse bascule.
Mais les old_ sont faits pour ne plus bouger, et les versions standard
sont en pleine évolution.
Fredho

Location:
LMDZ6/trunk/libf/phylmd/dyn1d
Files:
6 added
5 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/phylmd/dyn1d/1DUTILS.h

    r3540 r3541  
    14601460
    14611461!======================================================================
    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 none
    1466 
    1467 !-------------------------------------------------------------------------
    1468 ! Read TOGA-COARE forcing data
    1469 !-------------------------------------------------------------------------
    1470 
    1471       integer nlev_toga,nt_toga
    1472       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_toga
    1479 
    1480       integer k,ip
    1481       real bid
    1482 
    1483       integer iy,im,id,ih
    1484      
    1485        real plev_min
    1486 
    1487        plev_min = 55.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
    1488 
    1489       open(21,file=trim(fich_toga),form='formatted')
    1490       read(21,'(a)')
    1491       do ip = 1, nt_toga
    1492       read(21,'(a)')
    1493       read(21,'(a)')
    1494       read(21,223) iy, im, id, ih, bid, ts_toga(ip), bid,bid,bid,bid
    1495       read(21,'(a)')
    1496       read(21,'(a)')
    1497 
    1498        do k = 1, nlev_toga
    1499          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     ! K
    1505          q_toga(k,ip)=q_toga(k,ip)*0.001      ! kg/kg
    1506          w_toga(k,ip)=w_toga(k,ip)*100./3600. ! Pa/s
    1507 ! no water vapour tendency above 55 hPa
    1508          if (plev_toga(k,ip) .lt. plev_min) then
    1509           q_toga(k,ip) = 0.
    1510           hq_toga(k,ip) = 0.
    1511           vq_toga(k,ip) =0.
    1512          endif
    1513        enddo
    1514 
    1515          ts_toga(ip)=ts_toga(ip)+273.15       ! K
    1516        enddo
    1517        close(21)
    1518 
    1519   223 format(4i3,6f8.2)
    1520   230 format(6f9.3,4e11.3)
    1521 
    1522           return
    1523           end
    1524 
    1525 !-------------------------------------------------------------------------
    1526       SUBROUTINE read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)
    1527       implicit none
    1528 
    1529 !-------------------------------------------------------------------------
    1530 ! Read I.SANDU case forcing data
    1531 !-------------------------------------------------------------------------
    1532 
    1533       integer nlev_sandu,nt_sandu
    1534       real ts_sandu(nt_sandu)
    1535       character*80 fich_sandu
    1536 
    1537       integer ip
    1538       integer iy,im,id,ih
    1539 
    1540       real plev_min
    1541 
    1542       print*,'nlev_sandu',nlev_sandu
    1543       plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
    1544 
    1545       open(21,file=trim(fich_sandu),form='formatted')
    1546       read(21,'(a)')
    1547       do ip = 1, nt_sandu
    1548       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       enddo
    1553       close(21)
    1554 
    1555   223 format(4i3,f8.2)
    1556 
    1557           return
    1558           end
    1559 
    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 none
    1565 
    1566 !-------------------------------------------------------------------------
    1567 ! Read Astex case forcing data
    1568 !-------------------------------------------------------------------------
    1569 
    1570       integer nlev_astex,nt_astex
    1571       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_astex
    1574 
    1575       integer ip
    1576       integer iy,im,id,ih
    1577 
    1578        real plev_min
    1579 
    1580       print*,'nlev_astex',nlev_astex
    1581        plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
    1582 
    1583       open(21,file=trim(fich_astex),form='formatted')
    1584       read(21,'(a)')
    1585       read(21,'(a)')
    1586       do ip = 1, nt_astex
    1587       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.15
    1592       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       enddo
    1595       close(21)
    1596 
    1597   223 format(4i3,e13.2,f7.2,f7.3,f7.2,f7.3,f7.2)
    1598 
    1599           return
    1600           end
    1601 !=====================================================================
    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 experiment
    1607 
    1608 !      use netcdf
    1609 
    1610       implicit none
    1611 
    1612 #include "netcdf.inc"
    1613 
    1614       integer ntime,nlevel
    1615       integer l,k
    1616       character*80 :: fich_twpice
    1617       real*8 time(ntime)
    1618       real*8 lat, lon, alt, phis
    1619       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, ierr
    1635       integer nbvar3d
    1636       parameter(nbvar3d=20)
    1637       integer var3didin(nbvar3d)
    1638 
    1639       ierr = NF_OPEN(fich_twpice,NF_NOWRITE,nid)
    1640       if (ierr.NE.NF_NOERR) then
    1641          write(*,*) 'ERROR: Pb opening forcings cdf file '
    1642          write(*,*) NF_STRERROR(ierr)
    1643          stop ""
    1644       endif
    1645 
    1646       ierr=NF_INQ_VARID(nid,"lat",var3didin(1))
    1647          if(ierr/=NF_NOERR) then
    1648            write(*,*) NF_STRERROR(ierr)
    1649            stop 'lat'
    1650          endif
    1651      
    1652        ierr=NF_INQ_VARID(nid,"lon",var3didin(2))
    1653          if(ierr/=NF_NOERR) then
    1654            write(*,*) NF_STRERROR(ierr)
    1655            stop 'lon'
    1656          endif
    1657 
    1658        ierr=NF_INQ_VARID(nid,"alt",var3didin(3))
    1659          if(ierr/=NF_NOERR) then
    1660            write(*,*) NF_STRERROR(ierr)
    1661            stop 'alt'
    1662          endif
    1663 
    1664       ierr=NF_INQ_VARID(nid,"phis",var3didin(4))
    1665          if(ierr/=NF_NOERR) then
    1666            write(*,*) NF_STRERROR(ierr)
    1667            stop 'phis'
    1668          endif
    1669 
    1670       ierr=NF_INQ_VARID(nid,"T",var3didin(5))
    1671          if(ierr/=NF_NOERR) then
    1672            write(*,*) NF_STRERROR(ierr)
    1673            stop 'T'
    1674          endif
    1675 
    1676       ierr=NF_INQ_VARID(nid,"q",var3didin(6))
    1677          if(ierr/=NF_NOERR) then
    1678            write(*,*) NF_STRERROR(ierr)
    1679            stop 'q'
    1680          endif
    1681 
    1682       ierr=NF_INQ_VARID(nid,"u",var3didin(7))
    1683          if(ierr/=NF_NOERR) then
    1684            write(*,*) NF_STRERROR(ierr)
    1685            stop 'u'
    1686          endif
    1687 
    1688       ierr=NF_INQ_VARID(nid,"v",var3didin(8))
    1689          if(ierr/=NF_NOERR) then
    1690            write(*,*) NF_STRERROR(ierr)
    1691            stop 'v'
    1692          endif
    1693 
    1694       ierr=NF_INQ_VARID(nid,"omega",var3didin(9))
    1695          if(ierr/=NF_NOERR) then
    1696            write(*,*) NF_STRERROR(ierr)
    1697            stop 'omega'
    1698          endif
    1699 
    1700       ierr=NF_INQ_VARID(nid,"div",var3didin(10))
    1701          if(ierr/=NF_NOERR) then
    1702            write(*,*) NF_STRERROR(ierr)
    1703            stop 'div'
    1704          endif
    1705 
    1706       ierr=NF_INQ_VARID(nid,"T_adv_h",var3didin(11))
    1707          if(ierr/=NF_NOERR) then
    1708            write(*,*) NF_STRERROR(ierr)
    1709            stop 'T_adv_h'
    1710          endif
    1711 
    1712       ierr=NF_INQ_VARID(nid,"T_adv_v",var3didin(12))
    1713          if(ierr/=NF_NOERR) then
    1714            write(*,*) NF_STRERROR(ierr)
    1715            stop 'T_adv_v'
    1716          endif
    1717 
    1718       ierr=NF_INQ_VARID(nid,"q_adv_h",var3didin(13))
    1719          if(ierr/=NF_NOERR) then
    1720            write(*,*) NF_STRERROR(ierr)
    1721            stop 'q_adv_h'
    1722          endif
    1723 
    1724       ierr=NF_INQ_VARID(nid,"q_adv_v",var3didin(14))
    1725          if(ierr/=NF_NOERR) then
    1726            write(*,*) NF_STRERROR(ierr)
    1727            stop 'q_adv_v'
    1728          endif
    1729 
    1730       ierr=NF_INQ_VARID(nid,"s",var3didin(15))
    1731          if(ierr/=NF_NOERR) then
    1732            write(*,*) NF_STRERROR(ierr)
    1733            stop 's'
    1734          endif
    1735 
    1736       ierr=NF_INQ_VARID(nid,"s_adv_h",var3didin(16))
    1737          if(ierr/=NF_NOERR) then
    1738            write(*,*) NF_STRERROR(ierr)
    1739            stop 's_adv_h'
    1740          endif
    1741    
    1742       ierr=NF_INQ_VARID(nid,"s_adv_v",var3didin(17))
    1743          if(ierr/=NF_NOERR) then
    1744            write(*,*) NF_STRERROR(ierr)
    1745            stop 's_adv_v'
    1746          endif
    1747 
    1748       ierr=NF_INQ_VARID(nid,"p_srf_aver",var3didin(18))
    1749          if(ierr/=NF_NOERR) then
    1750            write(*,*) NF_STRERROR(ierr)
    1751            stop 'p_srf_aver'
    1752          endif
    1753 
    1754       ierr=NF_INQ_VARID(nid,"p_srf_center",var3didin(19))
    1755          if(ierr/=NF_NOERR) then
    1756            write(*,*) NF_STRERROR(ierr)
    1757            stop 'p_srf_center'
    1758          endif
    1759 
    1760       ierr=NF_INQ_VARID(nid,"T_srf",var3didin(20))
    1761          if(ierr/=NF_NOERR) then
    1762            write(*,*) NF_STRERROR(ierr)
    1763            stop 'T_srf'
    1764          endif
    1765 
    1766 !dimensions lecture
    1767       call catchaxis(nid,ntime,nlevel,time,lev,ierr)
    1768 
    1769 !pressure
    1770        do l=1,ntime
    1771        do k=1,nlevel
    1772           plev(k,l)=lev(k)
    1773        enddo
    1774        enddo
    1775          
    1776 #ifdef NC_DOUBLE
    1777          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),lat)
    1778 #else
    1779          ierr = NF_GET_VAR_REAL(nid,var3didin(1),lat)
    1780 #endif
    1781          if(ierr/=NF_NOERR) then
    1782             write(*,*) NF_STRERROR(ierr)
    1783             stop "getvarup"
    1784          endif
    1785 !         write(*,*)'lecture lat ok',lat
    1786 
    1787 #ifdef NC_DOUBLE
    1788          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),lon)
    1789 #else
    1790          ierr = NF_GET_VAR_REAL(nid,var3didin(2),lon)
    1791 #endif
    1792          if(ierr/=NF_NOERR) then
    1793             write(*,*) NF_STRERROR(ierr)
    1794             stop "getvarup"
    1795          endif
    1796 !         write(*,*)'lecture lon ok',lon
    1797  
    1798 #ifdef NC_DOUBLE
    1799          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),alt)
    1800 #else
    1801          ierr = NF_GET_VAR_REAL(nid,var3didin(3),alt)
    1802 #endif
    1803          if(ierr/=NF_NOERR) then
    1804             write(*,*) NF_STRERROR(ierr)
    1805             stop "getvarup"
    1806          endif
    1807 !          write(*,*)'lecture alt ok',alt
    1808  
    1809 #ifdef NC_DOUBLE
    1810          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),phis)
    1811 #else
    1812          ierr = NF_GET_VAR_REAL(nid,var3didin(4),phis)
    1813 #endif
    1814          if(ierr/=NF_NOERR) then
    1815             write(*,*) NF_STRERROR(ierr)
    1816             stop "getvarup"
    1817          endif
    1818 !          write(*,*)'lecture phis ok',phis
    1819          
    1820 #ifdef NC_DOUBLE
    1821          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),T)
    1822 #else
    1823          ierr = NF_GET_VAR_REAL(nid,var3didin(5),T)
    1824 #endif
    1825          if(ierr/=NF_NOERR) then
    1826             write(*,*) NF_STRERROR(ierr)
    1827             stop "getvarup"
    1828          endif
    1829 !         write(*,*)'lecture T ok'
    1830 
    1831 #ifdef NC_DOUBLE
    1832          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),q)
    1833 #else
    1834          ierr = NF_GET_VAR_REAL(nid,var3didin(6),q)
    1835 #endif
    1836          if(ierr/=NF_NOERR) then
    1837             write(*,*) NF_STRERROR(ierr)
    1838             stop "getvarup"
    1839          endif
    1840 !         write(*,*)'lecture q ok'
    1841 !q in kg/kg
    1842        do l=1,ntime
    1843        do k=1,nlevel
    1844           q(k,l)=q(k,l)/1000.
    1845        enddo
    1846        enddo
    1847 #ifdef NC_DOUBLE
    1848          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),u)
    1849 #else
    1850          ierr = NF_GET_VAR_REAL(nid,var3didin(7),u)
    1851 #endif
    1852          if(ierr/=NF_NOERR) then
    1853             write(*,*) NF_STRERROR(ierr)
    1854             stop "getvarup"
    1855          endif
    1856 !         write(*,*)'lecture u ok'
    1857 
    1858 #ifdef NC_DOUBLE
    1859          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),v)
    1860 #else
    1861          ierr = NF_GET_VAR_REAL(nid,var3didin(8),v)
    1862 #endif
    1863          if(ierr/=NF_NOERR) then
    1864             write(*,*) NF_STRERROR(ierr)
    1865             stop "getvarup"
    1866          endif
    1867 !         write(*,*)'lecture v ok'
    1868 
    1869 #ifdef NC_DOUBLE
    1870          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),omega)
    1871 #else
    1872          ierr = NF_GET_VAR_REAL(nid,var3didin(9),omega)
    1873 #endif
    1874          if(ierr/=NF_NOERR) then
    1875             write(*,*) NF_STRERROR(ierr)
    1876             stop "getvarup"
    1877          endif
    1878 !         write(*,*)'lecture omega ok'
    1879 !omega in mb/hour
    1880        do l=1,ntime
    1881        do k=1,nlevel
    1882           omega(k,l)=omega(k,l)*100./3600.
    1883        enddo
    1884        enddo
    1885 
    1886 #ifdef NC_DOUBLE
    1887          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),div)
    1888 #else
    1889          ierr = NF_GET_VAR_REAL(nid,var3didin(10),div)
    1890 #endif
    1891          if(ierr/=NF_NOERR) then
    1892             write(*,*) NF_STRERROR(ierr)
    1893             stop "getvarup"
    1894          endif
    1895 !         write(*,*)'lecture div ok'
    1896 
    1897 #ifdef NC_DOUBLE
    1898          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),T_adv_h)
    1899 #else
    1900          ierr = NF_GET_VAR_REAL(nid,var3didin(11),T_adv_h)
    1901 #endif
    1902          if(ierr/=NF_NOERR) then
    1903             write(*,*) NF_STRERROR(ierr)
    1904             stop "getvarup"
    1905          endif
    1906 !         write(*,*)'lecture T_adv_h ok'
    1907 !T adv in K/s
    1908        do l=1,ntime
    1909        do k=1,nlevel
    1910           T_adv_h(k,l)=T_adv_h(k,l)/3600.
    1911        enddo
    1912        enddo
    1913 
    1914 
    1915 #ifdef NC_DOUBLE
    1916          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),T_adv_v)
    1917 #else
    1918          ierr = NF_GET_VAR_REAL(nid,var3didin(12),T_adv_v)
    1919 #endif
    1920          if(ierr/=NF_NOERR) then
    1921             write(*,*) NF_STRERROR(ierr)
    1922             stop "getvarup"
    1923          endif
    1924 !         write(*,*)'lecture T_adv_v ok'
    1925 !T adv in K/s
    1926        do l=1,ntime
    1927        do k=1,nlevel
    1928           T_adv_v(k,l)=T_adv_v(k,l)/3600.
    1929        enddo
    1930        enddo
    1931 
    1932 #ifdef NC_DOUBLE
    1933          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),q_adv_h)
    1934 #else
    1935          ierr = NF_GET_VAR_REAL(nid,var3didin(13),q_adv_h)
    1936 #endif
    1937          if(ierr/=NF_NOERR) then
    1938             write(*,*) NF_STRERROR(ierr)
    1939             stop "getvarup"
    1940          endif
    1941 !         write(*,*)'lecture q_adv_h ok'
    1942 !q adv in kg/kg/s
    1943        do l=1,ntime
    1944        do k=1,nlevel
    1945           q_adv_h(k,l)=q_adv_h(k,l)/1000./3600.
    1946        enddo
    1947        enddo
    1948 
    1949 
    1950 #ifdef NC_DOUBLE
    1951          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),q_adv_v)
    1952 #else
    1953          ierr = NF_GET_VAR_REAL(nid,var3didin(14),q_adv_v)
    1954 #endif
    1955          if(ierr/=NF_NOERR) then
    1956             write(*,*) NF_STRERROR(ierr)
    1957             stop "getvarup"
    1958          endif
    1959 !         write(*,*)'lecture q_adv_v ok'
    1960 !q adv in kg/kg/s
    1961        do l=1,ntime
    1962        do k=1,nlevel
    1963           q_adv_v(k,l)=q_adv_v(k,l)/1000./3600.
    1964        enddo
    1965        enddo
    1966 
    1967 
    1968 #ifdef NC_DOUBLE
    1969          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),s)
    1970 #else
    1971          ierr = NF_GET_VAR_REAL(nid,var3didin(15),s)
    1972 #endif
    1973          if(ierr/=NF_NOERR) then
    1974             write(*,*) NF_STRERROR(ierr)
    1975             stop "getvarup"
    1976          endif
    1977 
    1978 #ifdef NC_DOUBLE
    1979          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),s_adv_h)
    1980 #else
    1981          ierr = NF_GET_VAR_REAL(nid,var3didin(16),s_adv_h)
    1982 #endif
    1983          if(ierr/=NF_NOERR) then
    1984             write(*,*) NF_STRERROR(ierr)
    1985             stop "getvarup"
    1986          endif
    1987 
    1988 #ifdef NC_DOUBLE
    1989          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),s_adv_v)
    1990 #else
    1991          ierr = NF_GET_VAR_REAL(nid,var3didin(17),s_adv_v)
    1992 #endif
    1993          if(ierr/=NF_NOERR) then
    1994             write(*,*) NF_STRERROR(ierr)
    1995             stop "getvarup"
    1996          endif
    1997 
    1998 #ifdef NC_DOUBLE
    1999          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),p_srf_aver)
    2000 #else
    2001          ierr = NF_GET_VAR_REAL(nid,var3didin(18),p_srf_aver)
    2002 #endif
    2003          if(ierr/=NF_NOERR) then
    2004             write(*,*) NF_STRERROR(ierr)
    2005             stop "getvarup"
    2006          endif
    2007 
    2008 #ifdef NC_DOUBLE
    2009          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),p_srf_center)
    2010 #else
    2011          ierr = NF_GET_VAR_REAL(nid,var3didin(19),p_srf_center)
    2012 #endif
    2013          if(ierr/=NF_NOERR) then
    2014             write(*,*) NF_STRERROR(ierr)
    2015             stop "getvarup"
    2016          endif
    2017 
    2018 #ifdef NC_DOUBLE
    2019          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),T_srf)
    2020 #else
    2021          ierr = NF_GET_VAR_REAL(nid,var3didin(20),T_srf)
    2022 #endif
    2023          if(ierr/=NF_NOERR) then
    2024             write(*,*) NF_STRERROR(ierr)
    2025             stop "getvarup"
    2026          endif
    2027 !         write(*,*)'lecture T_srf ok', T_srf
    2028 
    2029          return
    2030          end subroutine read_twpice
    2031 !=====================================================================
    2032          subroutine catchaxis(nid,ttm,llm,time,lev,ierr)
    2033 
    2034 !         use netcdf
    2035 
    2036          implicit none
    2037 #include "netcdf.inc"
    2038          integer nid,ttm,llm
    2039          real*8 time(ttm)
    2040          real*8 lev(llm)
    2041          integer ierr
    2042 
    2043          integer timevar,levvar
    2044          integer timelen,levlen
    2045          integer timedimin,levdimin
    2046 
    2047 ! Control & lecture on dimensions
    2048 ! ===============================
    2049          ierr=NF_INQ_DIMID(nid,"time",timedimin)
    2050          ierr=NF_INQ_VARID(nid,"time",timevar)
    2051          if (ierr.NE.NF_NOERR) then
    2052             write(*,*) 'ERROR: Field <time> is missing'
    2053             stop "" 
    2054          endif
    2055          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) then
    2060              write(*,*) 'ERROR: Field <lev> is lacking'
    2061              stop ""
    2062          endif
    2063          ierr=NF_INQ_DIMLEN(nid,levdimin,levlen)
    2064 
    2065          if((timelen/=ttm).or.(levlen/=llm)) then
    2066             write(*,*) 'ERROR: Not the good lenght for axis'
    2067             write(*,*) 'longitude: ',timelen,ttm+1
    2068             write(*,*) 'latitude: ',levlen,llm
    2069             stop "" 
    2070          endif
    2071 
    2072 !#ifdef NC_DOUBLE
    2073          ierr = NF_GET_VAR_DOUBLE(nid,timevar,time)
    2074          ierr = NF_GET_VAR_DOUBLE(nid,levvar,lev)
    2075 !#else
    2076 !        ierr = NF_GET_VAR_REAL(nid,timevar,time)
    2077 !        ierr = NF_GET_VAR_REAL(nid,levvar,lev)
    2078 !#endif
    2079 
    2080        return
    2081        end
    2082 !=====================================================================
    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 none
    2091 
    2092 #include "dimensions.h"
    2093 
    2094 !-------------------------------------------------------------------------
    2095 ! Vertical interpolation of SANDUREF forcing data onto model levels
    2096 !-------------------------------------------------------------------------
    2097 
    2098        integer nlevmax
    2099        parameter (nlevmax=41)
    2100        integer nlev_sandu,mxcalc
    2101 !       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,k2
    2117        real frac,frac1,frac2,fact
    2118 
    2119        do l = 1, llm
    2120 
    2121         if (play(l).ge.plev_prof(nlev_sandu)) then
    2122 
    2123         mxcalc=l
    2124          k1=0
    2125          k2=0
    2126 
    2127          if (play(l).le.plev_prof(1)) then
    2128 
    2129          do k = 1, nlev_sandu-1
    2130           if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then
    2131             k1=k
    2132             k2=k+1
    2133           endif
    2134          enddo
    2135 
    2136          if (k1.eq.0 .or. k2.eq.0) then
    2137           write(*,*) 'PB! k1, k2 = ',k1,k2
    2138           write(*,*) 'l,play(l) = ',l,play(l)/100
    2139          do k = 1, nlev_sandu-1
    2140           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2141          enddo
    2142          endif
    2143 
    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=1
    2157          k2=2
    2158          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 file
    2172 
    2173 !jyg
    2174          fact=20.*(plev_prof(nlev_sandu)-play(l))/plev_prof(nlev_sandu) !jyg
    2175          fact = max(fact,0.)                                           !jyg
    2176          fact = exp(-fact)                                             !jyg
    2177          t_mod(l)= t_prof(nlev_sandu)                                   !jyg
    2178          thl_mod(l)= thl_prof(nlev_sandu)                                   !jyg
    2179          q_mod(l)= q_prof(nlev_sandu)*fact                              !jyg
    2180          u_mod(l)= u_prof(nlev_sandu)*fact                              !jyg
    2181          v_mod(l)= v_prof(nlev_sandu)*fact                              !jyg
    2182          w_mod(l)= w_prof(nlev_sandu)*fact                              !jyg
    2183          omega_mod(l)= omega_prof(nlev_sandu)*fact                      !jyg
    2184          o3mmr_mod(l)= o3mmr_prof(nlev_sandu)*fact                      !jyg
    2185 
    2186         endif ! play
    2187 
    2188        enddo ! l
    2189 
    2190        do l = 1,llm
    2191 !      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        enddo
    2194 
    2195           return
    2196           end
    2197 !=====================================================================
    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 none
    2205 
    2206 #include "dimensions.h"
    2207 
    2208 !-------------------------------------------------------------------------
    2209 ! Vertical interpolation of Astex forcing data onto model levels
    2210 !-------------------------------------------------------------------------
    2211 
    2212        integer nlevmax
    2213        parameter (nlevmax=41)
    2214        integer nlev_astex,mxcalc
    2215 !       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,k2
    2232        real frac,frac1,frac2,fact
    2233 
    2234        do l = 1, llm
    2235 
    2236         if (play(l).ge.plev_prof(nlev_astex)) then
    2237 
    2238         mxcalc=l
    2239          k1=0
    2240          k2=0
    2241 
    2242          if (play(l).le.plev_prof(1)) then
    2243 
    2244          do k = 1, nlev_astex-1
    2245           if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then
    2246             k1=k
    2247             k2=k+1
    2248           endif
    2249          enddo
    2250 
    2251          if (k1.eq.0 .or. k2.eq.0) then
    2252           write(*,*) 'PB! k1, k2 = ',k1,k2
    2253           write(*,*) 'l,play(l) = ',l,play(l)/100
    2254          do k = 1, nlev_astex-1
    2255           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2256          enddo
    2257          endif
    2258 
    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=1
    2274          k2=2
    2275          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 file
    2291 
    2292 !jyg
    2293          fact=20.*(plev_prof(nlev_astex)-play(l))/plev_prof(nlev_astex) !jyg
    2294          fact = max(fact,0.)                                           !jyg
    2295          fact = exp(-fact)                                             !jyg
    2296          t_mod(l)= t_prof(nlev_astex)                                   !jyg
    2297          thl_mod(l)= thl_prof(nlev_astex)                                   !jyg
    2298          qv_mod(l)= qv_prof(nlev_astex)*fact                              !jyg
    2299          ql_mod(l)= ql_prof(nlev_astex)*fact                              !jyg
    2300          qt_mod(l)= qt_prof(nlev_astex)*fact                              !jyg
    2301          u_mod(l)= u_prof(nlev_astex)*fact                              !jyg
    2302          v_mod(l)= v_prof(nlev_astex)*fact                              !jyg
    2303          w_mod(l)= w_prof(nlev_astex)*fact                              !jyg
    2304          tke_mod(l)= tke_prof(nlev_astex)*fact                              !jyg
    2305          o3mmr_mod(l)= o3mmr_prof(nlev_astex)*fact                      !jyg
    2306 
    2307         endif ! play
    2308 
    2309        enddo ! l
    2310 
    2311        do l = 1,llm
    2312 !      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        enddo
    2315 
    2316           return
    2317           end
    2318 
    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 none
    2324 
    2325 !-------------------------------------------------------------------------
    2326 ! Read RICO forcing data
    2327 !-------------------------------------------------------------------------
    2328 #include "dimensions.h"
    2329 
    2330 
    2331       integer nlev_rico
    2332       real ts_rico,ps_rico
    2333       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_rico
    2346 
    2347       integer k,l
    2348 
    2349      
    2350       print*,fich_rico
    2351       open(21,file=trim(fich_rico),form='formatted')
    2352         do k=1,llm
    2353       zlay(k)=0.
    2354          enddo
    2355      
    2356         read(21,*) ps_rico,ts_rico
    2357         prico(1)=ps_rico
    2358         zrico(1)=0.0
    2359       do l=2,nlev_rico
    2360         read(21,*) k,prico(l),zrico(l)
    2361       enddo
    2362        close(21)
    2363 
    2364       do k=1,llm
    2365         do l=1,80
    2366           if(prico(l)>play(k)) then
    2367               if(play(k)>prico(l+1)) then
    2368                 zlay(k)=zrico(l)+(play(k)-prico(l)) *                      &
    2369      &              (zrico(l+1)-zrico(l))/(prico(l+1)-prico(l))
    2370               else
    2371                 zlay(k)=zrico(l)+(play(k)-prico(80))*                      &
    2372      &              (zrico(81)-zrico(80))/(prico(81)-prico(80))
    2373               endif
    2374           endif
    2375         enddo
    2376         print*,k,zlay(k)
    2377         ! U
    2378         if(0 < zlay(k) .and. zlay(k) < 4000) then
    2379           u_rico(k)=-9.9 + (-1.9 + 9.9)*zlay(k)/4000
    2380         elseif(4000 < zlay(k) .and. zlay(k) < 12000) then
    2381        u_rico(k)=  -1.9 + (30.0 + 1.9) /                                   &
    2382      &          (12000 - 4000) * (zlay(k) - 4000)
    2383         elseif(12000 < zlay(k) .and. zlay(k) < 13000) then
    2384           u_rico(k)=30.0
    2385         elseif(13000 < zlay(k) .and. zlay(k) < 20000) then
    2386           u_rico(k)=30.0 - (30.0) /                                        &
    2387      & (20000 - 13000) * (zlay(k) - 13000)
    2388         else
    2389           u_rico(k)=0.0
    2390         endif
    2391 
    2392 !Q_v
    2393         if(0 < zlay(k) .and. zlay(k) < 740) then
    2394           q_rico(k)=16.0 + (13.8 - 16.0) / (740) * zlay(k)
    2395         elseif(740 < zlay(k) .and. zlay(k) < 3260) then
    2396           q_rico(k)=13.8 + (2.4 - 13.8) /                                   &
    2397      &          (3260 - 740) * (zlay(k) - 740)
    2398         elseif(3260 < zlay(k) .and. zlay(k) < 4000) then
    2399           q_rico(k)=2.4 + (1.8 - 2.4) /                                    &
    2400      &               (4000 - 3260) * (zlay(k) - 3260)
    2401         elseif(4000 < zlay(k) .and. zlay(k) < 9000) then
    2402           q_rico(k)=1.8 + (0 - 1.8) /                                      &
    2403      &             (9000 - 4000) * (zlay(k) - 4000)
    2404         else
    2405           q_rico(k)=0.0
    2406         endif
    2407 
    2408 !T
    2409         if(0 < zlay(k) .and. zlay(k) < 740) then
    2410           t_rico(k)=299.2 + (292.0 - 299.2) / (740) * zlay(k)
    2411         elseif(740 < zlay(k) .and. zlay(k) < 4000) then
    2412           t_rico(k)=292.0 + (278.0 - 292.0) /                              &                       
    2413      &       (4000 - 740) * (zlay(k) - 740)
    2414         elseif(4000 < zlay(k) .and. zlay(k) < 15000) then
    2415           t_rico(k)=278.0 + (203.0 - 278.0) /                              &
    2416      &       (15000 - 4000) * (zlay(k) - 4000)
    2417         elseif(15000 < zlay(k) .and. zlay(k) < 17500) then
    2418           t_rico(k)=203.0 + (194.0 - 203.0) /                              &
    2419      &       (17500 - 15000)* (zlay(k) - 15000)
    2420         elseif(17500 < zlay(k) .and. zlay(k) < 20000) then
    2421           t_rico(k)=194.0 + (206.0 - 194.0) /                              &
    2422      &       (20000 - 17500)* (zlay(k) - 17500)
    2423         elseif(20000 < zlay(k) .and. zlay(k) < 60000) then
    2424           t_rico(k)=206.0 + (270.0 - 206.0) /                              &
    2425      &        (60000 - 20000)* (zlay(k) - 20000)
    2426         endif
    2427 
    2428 ! W
    2429         if(0 < zlay(k) .and. zlay(k) < 2260 ) then
    2430           w_rico(k)=- (0.005/2260) * zlay(k)
    2431         elseif(2260 < zlay(k) .and. zlay(k) < 4000 ) then
    2432           w_rico(k)=- 0.005
    2433         elseif(4000 < zlay(k) .and. zlay(k) < 5000 ) then
    2434        w_rico(k)=- 0.005 + (0.005/ (5000 - 4000)) * (zlay(k) - 4000)
    2435         else
    2436           w_rico(k)=0.0
    2437         endif
    2438 
    2439 ! dThrz+dTsw0+dTlw0
    2440         if(0 < zlay(k) .and. zlay(k) < 4000) then
    2441           dth_dyn(k)=- 2.51 / 86400 + (-2.18 + 2.51 )/                     &
    2442      &               (86400*4000) * zlay(k)
    2443         elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
    2444           dth_dyn(k)=- 2.18 / 86400 + ( 2.18 ) /                           &
    2445      &           (86400*(5000 - 4000)) * (zlay(k) - 4000)
    2446         else
    2447           dth_dyn(k)=0.0
    2448         endif
    2449 ! dQhrz
    2450         if(0 < zlay(k) .and. zlay(k) < 3000) then
    2451           dqh_dyn(k)=-1.0 / 86400 + (0.345 + 1.0)/                         &
    2452      &                    (86400*3000) * (zlay(k))
    2453         elseif(3000 < zlay(k) .and. zlay(k) < 4000) then
    2454           dqh_dyn(k)=0.345 / 86400
    2455         elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
    2456           dqh_dyn(k)=0.345 / 86400 +                                       &
    2457      &   (-0.345)/(86400 * (5000 - 4000)) * (zlay(k)-4000)
    2458         else
    2459           dqh_dyn(k)=0.0
    2460         endif
    2461 
    2462 !?        if(play(k)>6e4) then
    2463 !?          ratqs0(1,k)=ratqsbas*(plev(1)-play(k))/(plev(1)-6e4)
    2464 !?        elseif((play(k)>3e4).and.(play(k)<6e4)) then
    2465 !?          ratqs0(1,k)=ratqsbas+(ratqshaut-ratqsbas)&
    2466 !?                          *(6e4-play(k))/(6e4-3e4)
    2467 !?        else
    2468 !?          ratqs0(1,k)=ratqshaut
    2469 !?        endif
    2470 
    2471       enddo
    2472 
    2473       do k=1,llm
    2474       q_rico(k)=q_rico(k)/1e3
    2475       dqh_dyn(k)=dqh_dyn(k)/1e3
    2476       v_rico(k)=-3.8
    2477       enddo
    2478 
    2479           return
    2480           end
    2481 
    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 none
    2487 
    2488 !---------------------------------------------------------------------------------------
    2489 ! Time interpolation of a 2D field to the timestep corresponding to day
    2490 !
    2491 ! day: current julian day (e.g. 717538.2)
    2492 ! day1: first day of the simulation
    2493 ! 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_ref
    2498         integer nt_sandu,nlev_sandu
    2499         integer year_ini_sandu
    2500         real day, day1,day_ini_sandu,dt_sandu
    2501         real ts_sandu(nt_sandu)
    2502 ! outputs:
    2503         real ts_prof
    2504 ! local:
    2505         integer it_sandu1, it_sandu2
    2506         real timeit,time_sandu1,time_sandu2,frac
    2507 ! Check that initial day of the simulation consistent with SANDU period:
    2508        if (annee_ref.ne.2006 ) then
    2509         print*,'Pour SANDUREF, annee_ref doit etre 2006 '
    2510         print*,'Changer annee_ref dans run.def'
    2511         stop
    2512        endif
    2513 !      if (annee_ref.eq.2006 .and. day1.lt.day_ini_sandu) then
    2514 !       print*,'SANDUREF debute le 15 Juillet 2006 (jour julien=196)'
    2515 !       print*,'Changer dayref dans run.def'
    2516 !       stop
    2517 !      endif
    2518 
    2519 ! Determine timestep relative to the 1st day of TOGA-COARE:
    2520 !       timeit=(day-day1)*86400.
    2521 !       if (annee_ref.eq.1992) then
    2522 !        timeit=(day-day_ini_sandu)*86400.
    2523 !       else
    2524 !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
    2525 !       endif
    2526       timeit=(day-day_ini_sandu)*86400
    2527 
    2528 ! Determine the closest observation times:
    2529        it_sandu1=INT(timeit/dt_sandu)+1
    2530        it_sandu2=it_sandu1 + 1
    2531        time_sandu1=(it_sandu1-1)*dt_sandu
    2532        time_sandu2=(it_sandu2-1)*dt_sandu
    2533        print *,'timeit day day_ini_sandu',timeit,day,day_ini_sandu
    2534        print *,'it_sandu1,it_sandu2,time_sandu1,time_sandu2',              &
    2535      &          it_sandu1,it_sandu2,time_sandu1,time_sandu2
    2536 
    2537        if (it_sandu1 .ge. nt_sandu) then
    2538         write(*,*) 'PB-stop: day, it_sandu1, it_sandu2, timeit: '          &
    2539      &        ,day,it_sandu1,it_sandu2,timeit/86400.
    2540         stop
    2541        endif
    2542 
    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_prof
    2554 
    2555         return
    2556         END
    2557 !=====================================================================
    2558 !-------------------------------------------------------------------------
    2559       SUBROUTINE read_armcu(fich_armcu,nlev_armcu,nt_armcu,                &
    2560      & sens,flat,adv_theta,rad_theta,adv_qt)
    2561       implicit none
    2562 
    2563 !-------------------------------------------------------------------------
    2564 ! Read ARM_CU case forcing data
    2565 !-------------------------------------------------------------------------
    2566 
    2567       integer nlev_armcu,nt_armcu
    2568       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_armcu
    2571 
    2572       integer ip
    2573 
    2574       integer iy,im,id,ih,in
    2575 
    2576       print*,'nlev_armcu',nlev_armcu
    2577 
    2578       open(21,file=trim(fich_armcu),form='formatted')
    2579       read(21,'(a)')
    2580       do ip = 1, nt_armcu
    2581       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       enddo
    2588       close(21)
    2589 
    2590   223 format(5i3,5f8.3)
    2591 
    2592           return
    2593           end
    2594 
    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 none
    2603  
    2604 #include "dimensions.h"
    2605 
    2606 !-------------------------------------------------------------------------
    2607 ! Vertical interpolation of TOGA-COARE forcing data onto model levels
    2608 !-------------------------------------------------------------------------
    2609  
    2610        integer nlevmax
    2611        parameter (nlevmax=41)
    2612        integer nlev_toga,mxcalc
    2613 !       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,k2
    2631        real frac,frac1,frac2,fact
    2632  
    2633        do l = 1, llm
    2634 
    2635         if (play(l).ge.plev_prof(nlev_toga)) then
    2636  
    2637         mxcalc=l
    2638          k1=0
    2639          k2=0
    2640 
    2641          if (play(l).le.plev_prof(1)) then
    2642 
    2643          do k = 1, nlev_toga-1
    2644           if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then
    2645             k1=k
    2646             k2=k+1
    2647           endif
    2648          enddo
    2649 
    2650          if (k1.eq.0 .or. k2.eq.0) then
    2651           write(*,*) 'PB! k1, k2 = ',k1,k2
    2652           write(*,*) 'l,play(l) = ',l,play(l)/100
    2653          do k = 1, nlev_toga-1
    2654           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2655          enddo
    2656          endif
    2657 
    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=1
    2672          k2=2
    2673          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 file
    2688  
    2689 !jyg
    2690          fact=20.*(plev_prof(nlev_toga)-play(l))/plev_prof(nlev_toga) !jyg
    2691          fact = max(fact,0.)                                           !jyg
    2692          fact = exp(-fact)                                             !jyg
    2693          t_mod(l)= t_prof(nlev_toga)                                   !jyg
    2694          q_mod(l)= q_prof(nlev_toga)*fact                              !jyg
    2695          u_mod(l)= u_prof(nlev_toga)*fact                              !jyg
    2696          v_mod(l)= v_prof(nlev_toga)*fact                              !jyg
    2697          w_mod(l)= 0.0                                                 !jyg
    2698          ht_mod(l)= ht_prof(nlev_toga)                                 !jyg
    2699          vt_mod(l)= vt_prof(nlev_toga)                                 !jyg
    2700          hq_mod(l)= hq_prof(nlev_toga)*fact                            !jyg
    2701          vq_mod(l)= vq_prof(nlev_toga)*fact                            !jyg
    2702  
    2703         endif ! play
    2704  
    2705        enddo ! l
    2706 
    2707 !       do l = 1,llm
    2708 !       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 !       enddo
    2711  
    2712           return
    2713           end
    2714  
    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 none
    2725  
    2726 #include "dimensions.h"
    2727 
    2728 !-------------------------------------------------------------------------
    2729 ! Vertical interpolation of TOGA-COARE forcing data onto mod_casel levels
    2730 !-------------------------------------------------------------------------
    2731  
    2732        integer nlevmax
    2733        parameter (nlevmax=41)
    2734        integer nlev_cas,mxcalc
    2735 !       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,k2
    2759        real frac,frac1,frac2,fact
    2760  
    2761        do l = 1, llm
    2762 
    2763         if (play(l).ge.plev_prof_cas(nlev_cas)) then
    2764  
    2765         mxcalc=l
    2766          k1=0
    2767          k2=0
    2768 
    2769          if (play(l).le.plev_prof_cas(1)) then
    2770 
    2771          do k = 1, nlev_cas-1
    2772           if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then
    2773             k1=k
    2774             k2=k+1
    2775           endif
    2776          enddo
    2777 
    2778          if (k1.eq.0 .or. k2.eq.0) then
    2779           write(*,*) 'PB! k1, k2 = ',k1,k2
    2780           write(*,*) 'l,play(l) = ',l,play(l)/100
    2781          do k = 1, nlev_cas-1
    2782           write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100
    2783          enddo
    2784          endif
    2785 
    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=1
    2811          k2=2
    2812          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 file
    2838  
    2839 !jyg
    2840          fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg
    2841          fact = max(fact,0.)                                           !jyg
    2842          fact = exp(-fact)                                             !jyg
    2843          t_mod_cas(l)= t_prof_cas(nlev_cas)                                   !jyg
    2844          q_mod_cas(l)= q_prof_cas(nlev_cas)*fact                              !jyg
    2845          u_mod_cas(l)= u_prof_cas(nlev_cas)*fact                              !jyg
    2846          v_mod_cas(l)= v_prof_cas(nlev_cas)*fact                              !jyg
    2847          ug_mod_cas(l)= ug_prof_cas(nlev_cas)*fact                              !jyg
    2848          vg_mod_cas(l)= vg_prof_cas(nlev_cas)*fact                              !jyg
    2849          w_mod_cas(l)= 0.0                                                 !jyg
    2850          du_mod_cas(l)= du_prof_cas(nlev_cas)*fact
    2851          hu_mod_cas(l)= hu_prof_cas(nlev_cas)*fact                            !jyg
    2852          vu_mod_cas(l)= vu_prof_cas(nlev_cas)*fact                            !jyg
    2853          dv_mod_cas(l)= dv_prof_cas(nlev_cas)*fact
    2854          hv_mod_cas(l)= hv_prof_cas(nlev_cas)*fact                            !jyg
    2855          vv_mod_cas(l)= vv_prof_cas(nlev_cas)*fact                            !jyg
    2856          dt_mod_cas(l)= dt_prof_cas(nlev_cas)
    2857          ht_mod_cas(l)= ht_prof_cas(nlev_cas)                                 !jyg
    2858          vt_mod_cas(l)= vt_prof_cas(nlev_cas)                                 !jyg
    2859          dq_mod_cas(l)= dq_prof_cas(nlev_cas)*fact
    2860          hq_mod_cas(l)= hq_prof_cas(nlev_cas)*fact                            !jyg
    2861          vq_mod_cas(l)= vq_prof_cas(nlev_cas)*fact                            !jyg
    2862          dtrad_mod_cas(l)= dtrad_prof_cas(nlev_cas)*fact                      !jyg
    2863  
    2864         endif ! play
    2865  
    2866        enddo ! l
    2867 
    2868 !       do l = 1,llm
    2869 !       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 !       enddo
    2872  
    2873           return
    2874           end
    2875 !*****************************************************************************
    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 none
    2884  
    2885 #include "dimensions.h"
    2886 
    2887 !-------------------------------------------------------------------------
    2888 ! Vertical interpolation of Dice forcing data onto model levels
    2889 !-------------------------------------------------------------------------
    2890  
    2891        integer nlevmax
    2892        parameter (nlevmax=41)
    2893        integer nlev_dice,mxcalc,nt_dice
    2894  
    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,kp
    2909        real aa,frac,frac1,frac2,fact
    2910  
    2911        do l = 1, llm
    2912 
    2913         if (play(l).ge.plev_prof(nlev_dice)) then
    2914  
    2915         mxcalc=l
    2916          k1=0
    2917          k2=0
    2918 
    2919          if (play(l).le.plev_prof(1)) then
    2920 
    2921          do k = 1, nlev_dice-1
    2922           if (play(l).le.plev_prof(k) .and. play(l).gt.plev_prof(k+1)) then
    2923             k1=k
    2924             k2=k+1
    2925           endif
    2926          enddo
    2927 
    2928          if (k1.eq.0 .or. k2.eq.0) then
    2929           write(*,*) 'PB! k1, k2 = ',k1,k2
    2930           write(*,*) 'l,play(l) = ',l,play(l)/100
    2931          do k = 1, nlev_dice-1
    2932           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2933          enddo
    2934          endif
    2935 
    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=1
    2952          k2=2
    2953          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 file
    2970  
    2971 !jyg
    2972          fact=20.*(plev_prof(nlev_dice)-play(l))/plev_prof(nlev_dice) !jyg
    2973          fact = max(fact,0.)                                           !jyg
    2974          fact = exp(-fact)                                             !jyg
    2975          th_mod(l)= th_prof(nlev_dice)                                 !jyg
    2976          qv_mod(l)= qv_prof(nlev_dice)*fact                            !jyg
    2977          u_mod(l)= u_prof(nlev_dice)*fact                              !jyg
    2978          v_mod(l)= v_prof(nlev_dice)*fact                              !jyg
    2979          o3_mod(l)= o3_prof(nlev_dice)*fact                            !jyg
    2980          ht_mod(l)= ht_prof(nlev_dice)                                 !jyg
    2981          hq_mod(l)= hq_prof(nlev_dice)*fact                            !jyg
    2982          hu_mod(l)= hu_prof(nlev_dice)                                 !jyg
    2983          hv_mod(l)= hv_prof(nlev_dice)                                 !jyg
    2984          w_mod(l)= 0.                                                  !jyg
    2985          omega_mod(l)= 0.                                              !jyg
    2986  
    2987         endif ! play
    2988  
    2989        enddo ! l
    2990 
    2991 !       do l = 1,llm
    2992 !       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 !       enddo
    2995  
    2996           return
    2997           end
    2998 
    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 none
    3006 
    3007 !---------------------------------------------------------------------------------------
    3008 ! Time interpolation of a 2D field to the timestep corresponding to day
    3009 !
    3010 ! day: current julian day (e.g. 717538.2)
    3011 ! day1: first day of the simulation
    3012 ! 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_ref
    3018         integer nt_astex,nlev_astex
    3019         integer year_ini_astex
    3020         real day, day1,day_ini_astex,dt_astex
    3021         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_prof
    3025 ! local:
    3026         integer it_astex1, it_astex2
    3027         real timeit,time_astex1,time_astex2,frac
    3028 
    3029 ! Check that initial day of the simulation consistent with ASTEX period:
    3030        if (annee_ref.ne.1992 ) then
    3031         print*,'Pour Astex, annee_ref doit etre 1992 '
    3032         print*,'Changer annee_ref dans run.def'
    3033         stop
    3034        endif
    3035        if (annee_ref.eq.1992 .and. day1.lt.day_ini_astex) then
    3036         print*,'Astex debute le 13 Juin 1992 (jour julien=165)'
    3037         print*,'Changer dayref dans run.def'
    3038         stop
    3039        endif
    3040 
    3041 ! Determine timestep relative to the 1st day of TOGA-COARE:
    3042 !       timeit=(day-day1)*86400.
    3043 !       if (annee_ref.eq.1992) then
    3044 !        timeit=(day-day_ini_astex)*86400.
    3045 !       else
    3046 !        timeit=(day+2.-1.)*86400. ! 2 days between Jun13 and Jun15 1992
    3047 !       endif
    3048       timeit=(day-day_ini_astex)*86400
    3049 
    3050 ! Determine the closest observation times:
    3051        it_astex1=INT(timeit/dt_astex)+1
    3052        it_astex2=it_astex1 + 1
    3053        time_astex1=(it_astex1-1)*dt_astex
    3054        time_astex2=(it_astex2-1)*dt_astex
    3055        print *,'timeit day day_ini_astex',timeit,day,day_ini_astex
    3056        print *,'it_astex1,it_astex2,time_astex1,time_astex2',              &
    3057      &          it_astex1,it_astex2,time_astex1,time_astex2
    3058 
    3059        if (it_astex1 .ge. nt_astex) then
    3060         write(*,*) 'PB-stop: day, it_astex1, it_astex2, timeit: '          &
    3061      &        ,day,it_astex1,it_astex2,timeit/86400.
    3062         stop
    3063        endif
    3064 
    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_prof
    3086 
    3087         return
    3088         END
    3089 
    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 none
    3098 
    3099 !---------------------------------------------------------------------------------------
    3100 ! Time interpolation of a 2D field to the timestep corresponding to day
    3101 !
    3102 ! day: current julian day (e.g. 717538.2)
    3103 ! day1: first day of the simulation
    3104 ! 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_ref
    3112         integer nt_toga,nlev_toga
    3113         integer year_ini_toga
    3114         real day, day1,day_ini_toga,dt_toga
    3115         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_prof
    3123         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,k
    3130         real timeit,time_toga1,time_toga2,frac
    3131 
    3132 
    3133         if (forcing_type.eq.2) then
    3134 ! Check that initial day of the simulation consistent with TOGA-COARE period:
    3135        if (annee_ref.ne.1992 .and. annee_ref.ne.1993) then
    3136         print*,'Pour TOGA-COARE, annee_ref doit etre 1992 ou 1993'
    3137         print*,'Changer annee_ref dans run.def'
    3138         stop
    3139        endif
    3140        if (annee_ref.eq.1992 .and. day1.lt.day_ini_toga) then
    3141         print*,'TOGA-COARE a debute le 1er Nov 1992 (jour julien=306)'
    3142         print*,'Changer dayref dans run.def'
    3143         stop
    3144        endif
    3145        if (annee_ref.eq.1993 .and. day1.gt.day_ini_toga+119) then
    3146         print*,'TOGA-COARE a fini le 28 Feb 1993 (jour julien=59)'
    3147         print*,'Changer dayref ou nday dans run.def'
    3148         stop
    3149        endif
    3150 
    3151        else if (forcing_type.eq.4) then
    3152 
    3153 ! Check that initial day of the simulation consistent with TWP-ICE period:
    3154        if (annee_ref.ne.2006) then
    3155         print*,'Pour TWP-ICE, annee_ref doit etre 2006'
    3156         print*,'Changer annee_ref dans run.def'
    3157         stop
    3158        endif
    3159        if (annee_ref.eq.2006 .and. day1.lt.day_ini_toga) then
    3160         print*,'TWP-ICE a debute le 17 Jan 2006 (jour julien=17)'
    3161         print*,'Changer dayref dans run.def'
    3162         stop
    3163        endif
    3164        if (annee_ref.eq.2006 .and. day1.gt.day_ini_toga+26) then
    3165         print*,'TWP-ICE a fini le 12 Feb 2006 (jour julien=43)'
    3166         print*,'Changer dayref ou nday dans run.def'
    3167         stop
    3168        endif
    3169 
    3170        endif
    3171 
    3172 ! Determine timestep relative to the 1st day of TOGA-COARE:
    3173 !       timeit=(day-day1)*86400.
    3174 !       if (annee_ref.eq.1992) then
    3175 !        timeit=(day-day_ini_toga)*86400.
    3176 !       else
    3177 !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
    3178 !       endif
    3179       timeit=(day-day_ini_toga)*86400
    3180 
    3181 ! Determine the closest observation times:
    3182        it_toga1=INT(timeit/dt_toga)+1
    3183        it_toga2=it_toga1 + 1
    3184        time_toga1=(it_toga1-1)*dt_toga
    3185        time_toga2=(it_toga2-1)*dt_toga
    3186 
    3187        if (it_toga1 .ge. nt_toga) then
    3188         write(*,*) 'PB-stop: day, it_toga1, it_toga2, timeit: '            &
    3189      &        ,day,it_toga1,it_toga2,timeit/86400.
    3190         stop
    3191        endif
    3192 
    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_prof
    3203 
    3204        do k=1,nlev_toga
    3205         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         enddo
    3226 
    3227         return
    3228         END
    3229 
    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 none
    3240 
    3241 !---------------------------------------------------------------------------------------
    3242 ! Time interpolation of a 2D field to the timestep corresponding to day
    3243 !
    3244 ! day: current julian day (e.g. 717538.2)
    3245 ! day1: first day of the simulation
    3246 ! 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_ref
    3254         integer nt_dice,nlev_dice
    3255         integer year_ini_dice
    3256         real day, day1,day_ini_dice,dt_dice
    3257         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_prof
    3265         real ustar_prof,psurf_prof,ug_prof,vg_prof
    3266         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,k
    3271         real timeit,time_dice1,time_dice2,frac
    3272 
    3273 
    3274         if (forcing_type.eq.7) then
    3275 ! Check that initial day of the simulation consistent with Dice period:
    3276        print *,'annee_ref=',annee_ref
    3277        print *,'day1=',day1
    3278        print *,'day_ini_dice=',day_ini_dice
    3279        if (annee_ref.ne.1999) then
    3280         print*,'Pour Dice, annee_ref doit etre 1999'
    3281         print*,'Changer annee_ref dans run.def'
    3282         stop
    3283        endif
    3284        if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice) then
    3285         print*,'Dice a debute le 23 Oct 1999 (jour julien=296)'
    3286         print*,'Changer dayref dans run.def',day1,day_ini_dice
    3287         stop
    3288        endif
    3289        if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice+2) then
    3290         print*,'Dice a fini le 25 Oct 1999 (jour julien=298)'
    3291         print*,'Changer dayref ou nday dans run.def',day1,day_ini_dice
    3292         stop
    3293        endif
    3294 
    3295        endif
    3296 
    3297 ! Determine timestep relative to the 1st day of TOGA-COARE:
    3298 !       timeit=(day-day1)*86400.
    3299 !       if (annee_ref.eq.1992) then
    3300 !        timeit=(day-day_ini_dice)*86400.
    3301 !       else
    3302 !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
    3303 !       endif
    3304       timeit=(day-day_ini_dice)*86400
    3305 
    3306 ! Determine the closest observation times:
    3307        it_dice1=INT(timeit/dt_dice)+1
    3308        it_dice2=it_dice1 + 1
    3309        time_dice1=(it_dice1-1)*dt_dice
    3310        time_dice2=(it_dice2-1)*dt_dice
    3311 
    3312        if (it_dice1 .ge. nt_dice) then
    3313         write(*,*) 'PB-stop: day, it_dice1, it_dice2, timeit: ',day,it_dice1,it_dice2,timeit/86400.
    3314         stop
    3315        endif
    3316 
    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_prof
    3334 
    3335        do k=1,nlev_dice
    3336         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         enddo
    3343 
    3344         return
    3345         END
    3346 
    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 none
    3353 
    3354 !---------------------------------------------------------------------------------------
    3355 ! Time interpolation of a 2D field to the timestep corresponding to day
    3356 !
    3357 ! day: current julian day
    3358 ! day1: first day of the simulation
    3359 ! 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_ref
    3367         integer nt_gabls4,nlev_gabls4
    3368         integer year_ini_gabls4
    3369         real day, day1,day_ini_gabls4,dt_gabls4
    3370         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_prof
    3373 ! 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,k
    3378         real timeit,time_gabls41,time_gabls42,frac
    3379 
    3380 
    3381 
    3382 ! Check that initial day of the simulation consistent with gabls4 period:
    3383        if (forcing_type.eq.8 ) then
    3384        print *,'annee_ref=',annee_ref
    3385        print *,'day1=',day1
    3386        print *,'day_ini_gabls4=',day_ini_gabls4
    3387        if (annee_ref.ne.2009) then
    3388         print*,'Pour gabls4, annee_ref doit etre 2009'
    3389         print*,'Changer annee_ref dans run.def'
    3390         stop
    3391        endif
    3392        if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4) then
    3393         print*,'gabls4 a debute le 11 dec 2009 (jour julien=345)'
    3394         print*,'Changer dayref dans run.def',day1,day_ini_gabls4
    3395         stop
    3396        endif
    3397        if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4+2) then
    3398         print*,'gabls4 a fini le 12 dec 2009 (jour julien=346)'
    3399         print*,'Changer dayref ou nday dans run.def',day1,day_ini_gabls4
    3400         stop
    3401        endif
    3402        endif
    3403 
    3404       timeit=(day-day_ini_gabls4)*86400
    3405        print *,'day,day_ini_gabls4=',day,day_ini_gabls4
    3406        print *,'nt_gabls4,dt,timeit=',nt_gabls4,dt_gabls4,timeit
    3407 
    3408 ! Determine the closest observation times:
    3409        it_gabls41=INT(timeit/dt_gabls4)+1
    3410        it_gabls42=it_gabls41 + 1
    3411        time_gabls41=(it_gabls41-1)*dt_gabls4
    3412        time_gabls42=(it_gabls42-1)*dt_gabls4
    3413 
    3414        if (it_gabls41 .ge. nt_gabls4) then
    3415         write(*,*) 'PB-stop: day, it_gabls41, it_gabls42, timeit: ',day,it_gabls41,it_gabls42,timeit/86400.
    3416         stop
    3417        endif
    3418 
    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_gabls4
    3425         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         enddo
    3430         tg_prof=tg_gabls4(it_gabls42)-frac*(tg_gabls4(it_gabls42)-tg_gabls4(it_gabls41))
    3431         return
    3432         END
    3433 
    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 none
    3440 
    3441 !---------------------------------------------------------------------------------------
    3442 ! Time interpolation of a 2D field to the timestep corresponding to day
    3443 !
    3444 ! day: current julian day (e.g. 717538.2)
    3445 ! day1: first day of the simulation
    3446 ! 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 flux
    3449 ! fl= latent flux
    3450 ! at,rt,aqt= advective and radiative tendencies
    3451 !---------------------------------------------------------------------------------------
    3452 
    3453 ! inputs:
    3454         integer annee_ref
    3455         integer nt_armcu,nlev_armcu
    3456         integer year_ini_armcu
    3457         real day, day1,day_ini_armcu,dt_armcu
    3458         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_prof
    3462 ! local:
    3463         integer it_armcu1, it_armcu2,k
    3464         real timeit,time_armcu1,time_armcu2,frac
    3465 
    3466 ! Check that initial day of the simulation consistent with ARMCU period:
    3467        if (annee_ref.ne.1997 ) then
    3468         print*,'Pour ARMCU, annee_ref doit etre 1997 '
    3469         print*,'Changer annee_ref dans run.def'
    3470         stop
    3471        endif
    3472 
    3473       timeit=(day-day_ini_armcu)*86400
    3474 
    3475 ! Determine the closest observation times:
    3476        it_armcu1=INT(timeit/dt_armcu)+1
    3477        it_armcu2=it_armcu1 + 1
    3478        time_armcu1=(it_armcu1-1)*dt_armcu
    3479        time_armcu2=(it_armcu2-1)*dt_armcu
    3480        print *,'timeit day day_ini_armcu',timeit,day,day_ini_armcu
    3481        print *,'it_armcu1,it_armcu2,time_armcu1,time_armcu2',              &
    3482      &          it_armcu1,it_armcu2,time_armcu1,time_armcu2
    3483 
    3484        if (it_armcu1 .ge. nt_armcu) then
    3485         write(*,*) 'PB-stop: day, it_armcu1, it_armcu2, timeit: '          &
    3486      &        ,day,it_armcu1,it_armcu2,timeit/86400.
    3487         stop
    3488        endif
    3489 
    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_prof
    3509 
    3510         return
    3511         END
    3512 
    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 none
    3520 
    3521         integer nlev_max,kmax,kmax2,ntrac
    3522         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=1
    3533         integer :: ierr,k,itrac,nt1,nt2
    3534 
    3535         if(.not.(llesread)) return
    3536 
    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,*) kmax
    3540         do k=1,kmax
    3541           read (ilesfile,*) height1(k),thlprof(k),qtprof (k),               &
    3542      &                      uprof (k),vprof  (k),e12prof(k)
    3543         enddo
    3544         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,*) kmax2
    3549         if (kmax .ne. kmax2) then
    3550           print *, 'fichiers prof.inp et lscale.inp incompatibles :'
    3551           print *, 'nbre de niveaux : ',kmax,' et ',kmax2
    3552           stop 'lecture profiles'
    3553         endif
    3554         do k=1,kmax
    3555           read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k),         &
    3556      &                      dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k)
    3557         end do
    3558         do k=1,kmax
    3559           if (height(k) .ne. height1(k)) then
    3560             print *, 'fichiers prof.inp et lscale.inp incompatibles :'
    3561             print *, 'les niveaux different : ',k,height1(k), height(k)
    3562             stop
    3563           endif
    3564         end do
    3565         close(ilesfile)
    3566 
    3567        open(ilesfile,file='trac.inp.001',status='old',iostat=ierr)
    3568         if (ierr /= 0) then
    3569             print*,'WARNING : trac.inp does not exist'
    3570         else
    3571         read (ilesfile,*) kmax2,nt1,nt2
    3572         if (nt2>ntrac) then
    3573           stop 'Augmenter le nombre de traceurs dans traceur.def'
    3574         endif
    3575         if (kmax .ne. kmax2) then
    3576           print *, 'fichiers prof.inp et lscale.inp incompatibles :'
    3577           print *, 'nbre de niveaux : ',kmax,' et ',kmax2
    3578           stop 'lecture profiles'
    3579         endif
    3580         do k=1,kmax
    3581           read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2)
    3582         end do
    3583         close(ilesfile)
    3584         endif
    3585 
    3586         return
    3587         end
    3588 !======================================================================
    3589       subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof,       &
    3590      &       thlprof,qprof,uprof,vprof,wprof,omega,o3mmr)
    3591 !======================================================================
    3592       implicit none
    3593 
    3594         integer nlev_max,kmax
    3595         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=1
    3603         integer :: k,ierr
    3604 
    3605         if(.not.(llesread)) return
    3606 
    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,*) kmax
    3610         do k=1,kmax
    3611           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         enddo
    3615         close(ilesfile)
    3616 
    3617         return
    3618         end
    3619 
    3620 !======================================================================
    3621       subroutine readprofile_astex(nlev_max,kmax,height,pprof,tprof,       &
    3622      &    thlprof,qvprof,qlprof,qtprof,uprof,vprof,wprof,tkeprof,o3mmr)
    3623 !======================================================================
    3624       implicit none
    3625 
    3626         integer nlev_max,kmax
    3627         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=1
    3635         integer :: ierr,k
    3636 
    3637         if(.not.(llesread)) return
    3638 
    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,*) kmax
    3642         do k=1,kmax
    3643           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         enddo
    3647         close(ilesfile)
    3648 
    3649         return
    3650         end
    3651 
    3652 
    3653 
    3654 !======================================================================
    3655       subroutine readprofile_armcu(nlev_max,kmax,height,pprof,uprof,       &
    3656      &       vprof,thetaprof,tprof,qvprof,rvprof,aprof,bprof)
    3657 !======================================================================
    3658       implicit none
    3659 
    3660         integer nlev_max,kmax
    3661         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=1
    3669         integer, parameter :: ifile=2
    3670         integer :: ierr,jtot,k
    3671 
    3672         if(.not.(llesread)) return
    3673 
    3674 ! Read profiles at full levels
    3675        IF(nlev_max.EQ.19) THEN
    3676        open (ilesfile,file='prof.inp.19',status='old',iostat=ierr)
    3677        print *,'On ouvre prof.inp.19'
    3678        ELSE
    3679        open (ilesfile,file='prof.inp.40',status='old',iostat=ierr)
    3680        print *,'On ouvre prof.inp.40'
    3681        ENDIF
    3682         if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
    3683         read (ilesfile,*) kmax
    3684         do k=1,kmax
    3685           read (ilesfile,*) height(k)    ,pprof(k),  uprof(k), vprof(k),   &
    3686      &                      thetaprof(k) ,tprof(k), qvprof(k),rvprof(k)
    3687         enddo
    3688         close(ilesfile)
    3689 
    3690 ! Vertical coordinates half levels for eta-coordinates (plev = alpha + beta * psurf)
    3691        IF(nlev_max.EQ.19) THEN
    3692        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        ELSE
    3696        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        ENDIF
    3700         read (ifile,*) kmax
    3701         do k=1,kmax
    3702           read (ifile,*) jtot,aprof(k),bprof(k)
    3703         enddo
    3704         close(ifile)
    3705 
    3706         return
    3707         end
    3708 
    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 study
    3715 
    3716 
    3717       implicit none
    3718 
    3719 #include "netcdf.inc"
    3720 
    3721       integer ntime,nlevel
    3722       character*80 :: fich_fire
    3723       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, ierr
    3733       integer nbvar3d
    3734       parameter(nbvar3d=30)
    3735       integer var3didin(nbvar3d)
    3736 
    3737       ierr = NF_OPEN(fich_fire,NF_NOWRITE,nid)
    3738       if (ierr.NE.NF_NOERR) then
    3739          write(*,*) 'ERROR: Pb opening forcings nc file '
    3740          write(*,*) NF_STRERROR(ierr)
    3741          stop ""
    3742       endif
    3743 
    3744 
    3745        ierr=NF_INQ_VARID(nid,"zz",var3didin(1))
    3746          if(ierr/=NF_NOERR) then
    3747            write(*,*) NF_STRERROR(ierr)
    3748            stop 'lev'
    3749          endif
    3750 
    3751 
    3752       ierr=NF_INQ_VARID(nid,"thetal",var3didin(2))
    3753          if(ierr/=NF_NOERR) then
    3754            write(*,*) NF_STRERROR(ierr)
    3755            stop 'temp'
    3756          endif
    3757 
    3758       ierr=NF_INQ_VARID(nid,"qt",var3didin(3))
    3759          if(ierr/=NF_NOERR) then
    3760            write(*,*) NF_STRERROR(ierr)
    3761            stop 'qv'
    3762          endif
    3763 
    3764       ierr=NF_INQ_VARID(nid,"u",var3didin(4))
    3765          if(ierr/=NF_NOERR) then
    3766            write(*,*) NF_STRERROR(ierr)
    3767            stop 'u'
    3768          endif
    3769 
    3770       ierr=NF_INQ_VARID(nid,"v",var3didin(5))
    3771          if(ierr/=NF_NOERR) then
    3772            write(*,*) NF_STRERROR(ierr)
    3773            stop 'v'
    3774          endif
    3775 
    3776       ierr=NF_INQ_VARID(nid,"tke",var3didin(6))
    3777          if(ierr/=NF_NOERR) then
    3778            write(*,*) NF_STRERROR(ierr)
    3779            stop 'tke'
    3780          endif
    3781 
    3782       ierr=NF_INQ_VARID(nid,"ugeo",var3didin(7))
    3783          if(ierr/=NF_NOERR) then
    3784            write(*,*) NF_STRERROR(ierr)
    3785            stop 'ug'
    3786          endif
    3787 
    3788       ierr=NF_INQ_VARID(nid,"vgeo",var3didin(8))
    3789          if(ierr/=NF_NOERR) then
    3790            write(*,*) NF_STRERROR(ierr)
    3791            stop 'vg'
    3792          endif
    3793      
    3794       ierr=NF_INQ_VARID(nid,"wls",var3didin(9))
    3795          if(ierr/=NF_NOERR) then
    3796            write(*,*) NF_STRERROR(ierr)
    3797            stop 'wls'
    3798          endif
    3799 
    3800       ierr=NF_INQ_VARID(nid,"dqtdx",var3didin(10))
    3801          if(ierr/=NF_NOERR) then
    3802            write(*,*) NF_STRERROR(ierr)
    3803            stop 'dqtdx'
    3804          endif
    3805 
    3806       ierr=NF_INQ_VARID(nid,"dqtdy",var3didin(11))
    3807          if(ierr/=NF_NOERR) then
    3808            write(*,*) NF_STRERROR(ierr)
    3809            stop 'dqtdy'
    3810       endif
    3811 
    3812       ierr=NF_INQ_VARID(nid,"dqtdt",var3didin(12))
    3813          if(ierr/=NF_NOERR) then
    3814            write(*,*) NF_STRERROR(ierr)
    3815            stop 'dqtdt'
    3816       endif
    3817 
    3818       ierr=NF_INQ_VARID(nid,"thl_rad",var3didin(13))
    3819          if(ierr/=NF_NOERR) then
    3820            write(*,*) NF_STRERROR(ierr)
    3821            stop 'thl_rad'
    3822       endif
    3823 !dimensions lecture
    3824 !      call catchaxis(nid,ntime,nlevel,time,z,ierr)
    3825  
    3826 #ifdef NC_DOUBLE
    3827          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
    3828 #else
    3829          ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
    3830 #endif
    3831          if(ierr/=NF_NOERR) then
    3832             write(*,*) NF_STRERROR(ierr)
    3833             stop "getvarup"
    3834          endif
    3835 !          write(*,*)'lecture z ok',zz
    3836 
    3837 #ifdef NC_DOUBLE
    3838          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),thl)
    3839 #else
    3840          ierr = NF_GET_VAR_REAL(nid,var3didin(2),thl)
    3841 #endif
    3842          if(ierr/=NF_NOERR) then
    3843             write(*,*) NF_STRERROR(ierr)
    3844             stop "getvarup"
    3845          endif
    3846 !          write(*,*)'lecture thl ok',thl
    3847 
    3848 #ifdef NC_DOUBLE
    3849          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),qt)
    3850 #else
    3851          ierr = NF_GET_VAR_REAL(nid,var3didin(3),qt)
    3852 #endif
    3853          if(ierr/=NF_NOERR) then
    3854             write(*,*) NF_STRERROR(ierr)
    3855             stop "getvarup"
    3856          endif
    3857 !          write(*,*)'lecture qt ok',qt
    3858  
    3859 #ifdef NC_DOUBLE
    3860          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),u)
    3861 #else
    3862          ierr = NF_GET_VAR_REAL(nid,var3didin(4),u)
    3863 #endif
    3864          if(ierr/=NF_NOERR) then
    3865             write(*,*) NF_STRERROR(ierr)
    3866             stop "getvarup"
    3867          endif
    3868 !          write(*,*)'lecture u ok',u
    3869 
    3870 #ifdef NC_DOUBLE
    3871          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),v)
    3872 #else
    3873          ierr = NF_GET_VAR_REAL(nid,var3didin(5),v)
    3874 #endif
    3875          if(ierr/=NF_NOERR) then
    3876             write(*,*) NF_STRERROR(ierr)
    3877             stop "getvarup"
    3878          endif
    3879 !          write(*,*)'lecture v ok',v
    3880 
    3881 #ifdef NC_DOUBLE
    3882          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tke)
    3883 #else
    3884          ierr = NF_GET_VAR_REAL(nid,var3didin(6),tke)
    3885 #endif
    3886          if(ierr/=NF_NOERR) then
    3887             write(*,*) NF_STRERROR(ierr)
    3888             stop "getvarup"
    3889          endif
    3890 !          write(*,*)'lecture tke ok',tke
    3891 
    3892 #ifdef NC_DOUBLE
    3893          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ug)
    3894 #else
    3895          ierr = NF_GET_VAR_REAL(nid,var3didin(7),ug)
    3896 #endif
    3897          if(ierr/=NF_NOERR) then
    3898             write(*,*) NF_STRERROR(ierr)
    3899             stop "getvarup"
    3900          endif
    3901 !          write(*,*)'lecture ug ok',ug
    3902 
    3903 #ifdef NC_DOUBLE
    3904          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),vg)
    3905 #else
    3906          ierr = NF_GET_VAR_REAL(nid,var3didin(8),vg)
    3907 #endif
    3908          if(ierr/=NF_NOERR) then
    3909             write(*,*) NF_STRERROR(ierr)
    3910             stop "getvarup"
    3911          endif
    3912 !          write(*,*)'lecture vg ok',vg
    3913 
    3914 #ifdef NC_DOUBLE
    3915          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),wls)
    3916 #else
    3917          ierr = NF_GET_VAR_REAL(nid,var3didin(9),wls)
    3918 #endif
    3919          if(ierr/=NF_NOERR) then
    3920             write(*,*) NF_STRERROR(ierr)
    3921             stop "getvarup"
    3922          endif
    3923 !          write(*,*)'lecture wls ok',wls
    3924 
    3925 #ifdef NC_DOUBLE
    3926          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),dqtdx)
    3927 #else
    3928          ierr = NF_GET_VAR_REAL(nid,var3didin(10),dqtdx)
    3929 #endif
    3930          if(ierr/=NF_NOERR) then
    3931             write(*,*) NF_STRERROR(ierr)
    3932             stop "getvarup"
    3933          endif
    3934 !          write(*,*)'lecture dqtdx ok',dqtdx
    3935 
    3936 #ifdef NC_DOUBLE
    3937          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),dqtdy)
    3938 #else
    3939          ierr = NF_GET_VAR_REAL(nid,var3didin(11),dqtdy)
    3940 #endif
    3941          if(ierr/=NF_NOERR) then
    3942             write(*,*) NF_STRERROR(ierr)
    3943             stop "getvarup"
    3944          endif
    3945 !          write(*,*)'lecture dqtdy ok',dqtdy
    3946 
    3947 #ifdef NC_DOUBLE
    3948          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),dqtdt)
    3949 #else
    3950          ierr = NF_GET_VAR_REAL(nid,var3didin(12),dqtdt)
    3951 #endif
    3952          if(ierr/=NF_NOERR) then
    3953             write(*,*) NF_STRERROR(ierr)
    3954             stop "getvarup"
    3955          endif
    3956 !          write(*,*)'lecture dqtdt ok',dqtdt
    3957 
    3958 #ifdef NC_DOUBLE
    3959          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),thl_rad)
    3960 #else
    3961          ierr = NF_GET_VAR_REAL(nid,var3didin(13),thl_rad)
    3962 #endif
    3963          if(ierr/=NF_NOERR) then
    3964             write(*,*) NF_STRERROR(ierr)
    3965             stop "getvarup"
    3966          endif
    3967 !          write(*,*)'lecture thl_rad ok',thl_rad
    3968 
    3969          return
    3970          end subroutine read_fire
    3971 !=====================================================================
    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 study
    3978 
    3979 
    3980       implicit none
    3981 
    3982 #include "netcdf.inc"
    3983 #include "YOMCST.h"
    3984 
    3985       integer ntime,nlevel
    3986       integer l,k
    3987       character*80 :: fich_dice
    3988       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 pzero
    3998 
    3999       integer nid, ierr
    4000       integer nbvar3d
    4001       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) then
    4007          write(*,*) 'ERROR: Pb opening forcings nc file '
    4008          write(*,*) NF_STRERROR(ierr)
    4009          stop ""
    4010       endif
    4011 
    4012 
    4013        ierr=NF_INQ_VARID(nid,"height",var3didin(1))
    4014          if(ierr/=NF_NOERR) then
    4015            write(*,*) NF_STRERROR(ierr)
    4016            stop 'height'
    4017          endif
    4018 
    4019        ierr=NF_INQ_VARID(nid,"pf",var3didin(11))
    4020          if(ierr/=NF_NOERR) then
    4021            write(*,*) NF_STRERROR(ierr)
    4022            stop 'pf'
    4023          endif
    4024 
    4025       ierr=NF_INQ_VARID(nid,"theta",var3didin(12))
    4026          if(ierr/=NF_NOERR) then
    4027            write(*,*) NF_STRERROR(ierr)
    4028            stop 'theta'
    4029          endif
    4030 
    4031       ierr=NF_INQ_VARID(nid,"qv",var3didin(13))
    4032          if(ierr/=NF_NOERR) then
    4033            write(*,*) NF_STRERROR(ierr)
    4034            stop 'qv'
    4035          endif
    4036 
    4037       ierr=NF_INQ_VARID(nid,"u",var3didin(14))
    4038          if(ierr/=NF_NOERR) then
    4039            write(*,*) NF_STRERROR(ierr)
    4040            stop 'u'
    4041          endif
    4042 
    4043       ierr=NF_INQ_VARID(nid,"v",var3didin(15))
    4044          if(ierr/=NF_NOERR) then
    4045            write(*,*) NF_STRERROR(ierr)
    4046            stop 'v'
    4047          endif
    4048 
    4049       ierr=NF_INQ_VARID(nid,"o3mmr",var3didin(16))
    4050          if(ierr/=NF_NOERR) then
    4051            write(*,*) NF_STRERROR(ierr)
    4052            stop 'o3'
    4053          endif
    4054 
    4055       ierr=NF_INQ_VARID(nid,"shf",var3didin(2))
    4056          if(ierr/=NF_NOERR) then
    4057            write(*,*) NF_STRERROR(ierr)
    4058            stop 'shf'
    4059          endif
    4060 
    4061       ierr=NF_INQ_VARID(nid,"lhf",var3didin(3))
    4062          if(ierr/=NF_NOERR) then
    4063            write(*,*) NF_STRERROR(ierr)
    4064            stop 'lhf'
    4065          endif
    4066      
    4067       ierr=NF_INQ_VARID(nid,"lwup",var3didin(4))
    4068          if(ierr/=NF_NOERR) then
    4069            write(*,*) NF_STRERROR(ierr)
    4070            stop 'lwup'
    4071          endif
    4072 
    4073       ierr=NF_INQ_VARID(nid,"swup",var3didin(5))
    4074          if(ierr/=NF_NOERR) then
    4075            write(*,*) NF_STRERROR(ierr)
    4076            stop 'dqtdx'
    4077          endif
    4078 
    4079       ierr=NF_INQ_VARID(nid,"Tg",var3didin(6))
    4080          if(ierr/=NF_NOERR) then
    4081            write(*,*) NF_STRERROR(ierr)
    4082            stop 'Tg'
    4083       endif
    4084 
    4085       ierr=NF_INQ_VARID(nid,"ustar",var3didin(7))
    4086          if(ierr/=NF_NOERR) then
    4087            write(*,*) NF_STRERROR(ierr)
    4088            stop 'ustar'
    4089       endif
    4090 
    4091       ierr=NF_INQ_VARID(nid,"psurf",var3didin(8))
    4092          if(ierr/=NF_NOERR) then
    4093            write(*,*) NF_STRERROR(ierr)
    4094            stop 'psurf'
    4095       endif
    4096 
    4097       ierr=NF_INQ_VARID(nid,"Ug",var3didin(9))
    4098          if(ierr/=NF_NOERR) then
    4099            write(*,*) NF_STRERROR(ierr)
    4100            stop 'Ug'
    4101       endif
    4102 
    4103       ierr=NF_INQ_VARID(nid,"Vg",var3didin(10))
    4104          if(ierr/=NF_NOERR) then
    4105            write(*,*) NF_STRERROR(ierr)
    4106            stop 'Vg'
    4107       endif
    4108 
    4109       ierr=NF_INQ_VARID(nid,"hadvT",var3didin(17))
    4110          if(ierr/=NF_NOERR) then
    4111            write(*,*) NF_STRERROR(ierr)
    4112            stop 'hadvT'
    4113       endif
    4114 
    4115       ierr=NF_INQ_VARID(nid,"hadvq",var3didin(18))
    4116          if(ierr/=NF_NOERR) then
    4117            write(*,*) NF_STRERROR(ierr)
    4118            stop 'hadvq'
    4119       endif
    4120 
    4121       ierr=NF_INQ_VARID(nid,"hadvu",var3didin(19))
    4122          if(ierr/=NF_NOERR) then
    4123            write(*,*) NF_STRERROR(ierr)
    4124            stop 'hadvu'
    4125       endif
    4126 
    4127       ierr=NF_INQ_VARID(nid,"hadvv",var3didin(20))
    4128          if(ierr/=NF_NOERR) then
    4129            write(*,*) NF_STRERROR(ierr)
    4130            stop 'hadvv'
    4131       endif
    4132 
    4133       ierr=NF_INQ_VARID(nid,"w",var3didin(21))
    4134          if(ierr/=NF_NOERR) then
    4135            write(*,*) NF_STRERROR(ierr)
    4136            stop 'w'
    4137       endif
    4138 
    4139       ierr=NF_INQ_VARID(nid,"omega",var3didin(22))
    4140          if(ierr/=NF_NOERR) then
    4141            write(*,*) NF_STRERROR(ierr)
    4142            stop 'omega'
    4143       endif
    4144 !dimensions lecture
    4145 !      call catchaxis(nid,ntime,nlevel,time,z,ierr)
    4146  
    4147 #ifdef NC_DOUBLE
    4148          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
    4149 #else
    4150          ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
    4151 #endif
    4152          if(ierr/=NF_NOERR) then
    4153             write(*,*) NF_STRERROR(ierr)
    4154             stop "getvarup"
    4155          endif
    4156 !          write(*,*)'lecture zz ok',zz
    4157  
    4158 #ifdef NC_DOUBLE
    4159          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),pres)
    4160 #else
    4161          ierr = NF_GET_VAR_REAL(nid,var3didin(11),pres)
    4162 #endif
    4163          if(ierr/=NF_NOERR) then
    4164             write(*,*) NF_STRERROR(ierr)
    4165             stop "getvarup"
    4166          endif
    4167 !          write(*,*)'lecture pres ok',pres
    4168 
    4169 #ifdef NC_DOUBLE
    4170          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),th)
    4171 #else
    4172          ierr = NF_GET_VAR_REAL(nid,var3didin(12),th)
    4173 #endif
    4174          if(ierr/=NF_NOERR) then
    4175             write(*,*) NF_STRERROR(ierr)
    4176             stop "getvarup"
    4177          endif
    4178 !          write(*,*)'lecture th ok',th
    4179            do k=1,nlevel
    4180              t(k)=th(k)*(pres(k)/pzero)**rkappa
    4181            enddo
    4182 
    4183 #ifdef NC_DOUBLE
    4184          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),qv)
    4185 #else
    4186          ierr = NF_GET_VAR_REAL(nid,var3didin(13),qv)
    4187 #endif
    4188          if(ierr/=NF_NOERR) then
    4189             write(*,*) NF_STRERROR(ierr)
    4190             stop "getvarup"
    4191          endif
    4192 !          write(*,*)'lecture qv ok',qv
    4193  
    4194 #ifdef NC_DOUBLE
    4195          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),u)
    4196 #else
    4197          ierr = NF_GET_VAR_REAL(nid,var3didin(14),u)
    4198 #endif
    4199          if(ierr/=NF_NOERR) then
    4200             write(*,*) NF_STRERROR(ierr)
    4201             stop "getvarup"
    4202          endif
    4203 !          write(*,*)'lecture u ok',u
    4204 
    4205 #ifdef NC_DOUBLE
    4206          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),v)
    4207 #else
    4208          ierr = NF_GET_VAR_REAL(nid,var3didin(15),v)
    4209 #endif
    4210          if(ierr/=NF_NOERR) then
    4211             write(*,*) NF_STRERROR(ierr)
    4212             stop "getvarup"
    4213          endif
    4214 !          write(*,*)'lecture v ok',v
    4215 
    4216 #ifdef NC_DOUBLE
    4217          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),o3)
    4218 #else
    4219          ierr = NF_GET_VAR_REAL(nid,var3didin(16),o3)
    4220 #endif
    4221          if(ierr/=NF_NOERR) then
    4222             write(*,*) NF_STRERROR(ierr)
    4223             stop "getvarup"
    4224          endif
    4225 !          write(*,*)'lecture o3 ok',o3
    4226 
    4227 #ifdef NC_DOUBLE
    4228          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),shf)
    4229 #else
    4230          ierr = NF_GET_VAR_REAL(nid,var3didin(2),shf)
    4231 #endif
    4232          if(ierr/=NF_NOERR) then
    4233             write(*,*) NF_STRERROR(ierr)
    4234             stop "getvarup"
    4235          endif
    4236 !          write(*,*)'lecture shf ok',shf
    4237 
    4238 #ifdef NC_DOUBLE
    4239          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),lhf)
    4240 #else
    4241          ierr = NF_GET_VAR_REAL(nid,var3didin(3),lhf)
    4242 #endif
    4243          if(ierr/=NF_NOERR) then
    4244             write(*,*) NF_STRERROR(ierr)
    4245             stop "getvarup"
    4246          endif
    4247 !          write(*,*)'lecture lhf ok',lhf
    4248 
    4249 #ifdef NC_DOUBLE
    4250          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),lwup)
    4251 #else
    4252          ierr = NF_GET_VAR_REAL(nid,var3didin(4),lwup)
    4253 #endif
    4254          if(ierr/=NF_NOERR) then
    4255             write(*,*) NF_STRERROR(ierr)
    4256             stop "getvarup"
    4257          endif
    4258 !          write(*,*)'lecture lwup ok',lwup
    4259 
    4260 #ifdef NC_DOUBLE
    4261          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),swup)
    4262 #else
    4263          ierr = NF_GET_VAR_REAL(nid,var3didin(5),swup)
    4264 #endif
    4265          if(ierr/=NF_NOERR) then
    4266             write(*,*) NF_STRERROR(ierr)
    4267             stop "getvarup"
    4268          endif
    4269 !          write(*,*)'lecture swup ok',swup
    4270 
    4271 #ifdef NC_DOUBLE
    4272          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tg)
    4273 #else
    4274          ierr = NF_GET_VAR_REAL(nid,var3didin(6),tg)
    4275 #endif
    4276          if(ierr/=NF_NOERR) then
    4277             write(*,*) NF_STRERROR(ierr)
    4278             stop "getvarup"
    4279          endif
    4280 !          write(*,*)'lecture tg ok',tg
    4281 
    4282 #ifdef NC_DOUBLE
    4283          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ustar)
    4284 #else
    4285          ierr = NF_GET_VAR_REAL(nid,var3didin(7),ustar)
    4286 #endif
    4287          if(ierr/=NF_NOERR) then
    4288             write(*,*) NF_STRERROR(ierr)
    4289             stop "getvarup"
    4290          endif
    4291 !          write(*,*)'lecture ustar ok',ustar
    4292 
    4293 #ifdef NC_DOUBLE
    4294          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),psurf)
    4295 #else
    4296          ierr = NF_GET_VAR_REAL(nid,var3didin(8),psurf)
    4297 #endif
    4298          if(ierr/=NF_NOERR) then
    4299             write(*,*) NF_STRERROR(ierr)
    4300             stop "getvarup"
    4301          endif
    4302 !          write(*,*)'lecture psurf ok',psurf
    4303 
    4304 #ifdef NC_DOUBLE
    4305          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),ug)
    4306 #else
    4307          ierr = NF_GET_VAR_REAL(nid,var3didin(9),ug)
    4308 #endif
    4309          if(ierr/=NF_NOERR) then
    4310             write(*,*) NF_STRERROR(ierr)
    4311             stop "getvarup"
    4312          endif
    4313 !          write(*,*)'lecture ug ok',ug
    4314 
    4315 #ifdef NC_DOUBLE
    4316          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),vg)
    4317 #else
    4318          ierr = NF_GET_VAR_REAL(nid,var3didin(10),vg)
    4319 #endif
    4320          if(ierr/=NF_NOERR) then
    4321             write(*,*) NF_STRERROR(ierr)
    4322             stop "getvarup"
    4323          endif
    4324 !          write(*,*)'lecture vg ok',vg
    4325 
    4326 #ifdef NC_DOUBLE
    4327          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hadvt)
    4328 #else
    4329          ierr = NF_GET_VAR_REAL(nid,var3didin(17),hadvt)
    4330 #endif
    4331          if(ierr/=NF_NOERR) then
    4332             write(*,*) NF_STRERROR(ierr)
    4333             stop "getvarup"
    4334          endif
    4335 !          write(*,*)'lecture hadvt ok',hadvt
    4336 
    4337 #ifdef NC_DOUBLE
    4338          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),hadvq)
    4339 #else
    4340          ierr = NF_GET_VAR_REAL(nid,var3didin(18),hadvq)
    4341 #endif
    4342          if(ierr/=NF_NOERR) then
    4343             write(*,*) NF_STRERROR(ierr)
    4344             stop "getvarup"
    4345          endif
    4346 !          write(*,*)'lecture hadvq ok',hadvq
    4347 
    4348 #ifdef NC_DOUBLE
    4349          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),hadvu)
    4350 #else
    4351          ierr = NF_GET_VAR_REAL(nid,var3didin(19),hadvu)
    4352 #endif
    4353          if(ierr/=NF_NOERR) then
    4354             write(*,*) NF_STRERROR(ierr)
    4355             stop "getvarup"
    4356          endif
    4357 !          write(*,*)'lecture hadvu ok',hadvu
    4358 
    4359 #ifdef NC_DOUBLE
    4360          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),hadvv)
    4361 #else
    4362          ierr = NF_GET_VAR_REAL(nid,var3didin(20),hadvv)
    4363 #endif
    4364          if(ierr/=NF_NOERR) then
    4365             write(*,*) NF_STRERROR(ierr)
    4366             stop "getvarup"
    4367          endif
    4368 !          write(*,*)'lecture hadvv ok',hadvv
    4369 
    4370 #ifdef NC_DOUBLE
    4371          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),w)
    4372 #else
    4373          ierr = NF_GET_VAR_REAL(nid,var3didin(21),w)
    4374 #endif
    4375          if(ierr/=NF_NOERR) then
    4376             write(*,*) NF_STRERROR(ierr)
    4377             stop "getvarup"
    4378          endif
    4379 !          write(*,*)'lecture w ok',w
    4380 
    4381 #ifdef NC_DOUBLE
    4382          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),omega)
    4383 #else
    4384          ierr = NF_GET_VAR_REAL(nid,var3didin(22),omega)
    4385 #endif
    4386          if(ierr/=NF_NOERR) then
    4387             write(*,*) NF_STRERROR(ierr)
    4388             stop "getvarup"
    4389          endif
    4390 !          write(*,*)'lecture omega ok',omega
    4391 
    4392          return
    4393          end subroutine read_dice
    4394 !=====================================================================
    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 study
    4399 
    4400 
    4401       implicit none
    4402 
    4403 #include "netcdf.inc"
    4404 
    4405       integer ntime,nlevel,nsol
    4406       integer l,k
    4407       character*80 :: fich_gabls4
    4408       real*8 time(ntime)
    4409 
    4410 !  ATTENTION: visiblement quand on lit gabls4_driver.nc on recupere les donnees
    4411 ! dans un ordre inverse par rapport a la convention LMDZ
    4412 ! ==> il faut tout inverser  (MPL 20141024)
    4413 ! les variables indexees "_i" sont celles qui sont lues dans gabls4_driver.nc
    4414       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, ierr
    4425       integer nbvar3d
    4426       parameter(nbvar3d=30)
    4427       integer var3didin(nbvar3d)
    4428 
    4429       ierr = NF_OPEN(fich_gabls4,NF_NOWRITE,nid)
    4430       if (ierr.NE.NF_NOERR) then
    4431          write(*,*) 'ERROR: Pb opening forcings nc file '
    4432          write(*,*) NF_STRERROR(ierr)
    4433          stop ""
    4434       endif
    4435 
    4436 
    4437        ierr=NF_INQ_VARID(nid,"height",var3didin(1))
    4438          if(ierr/=NF_NOERR) then
    4439            write(*,*) NF_STRERROR(ierr)
    4440            stop 'height'
    4441          endif
    4442 
    4443       ierr=NF_INQ_VARID(nid,"depth_sn",var3didin(2))
    4444          if(ierr/=NF_NOERR) then
    4445            write(*,*) NF_STRERROR(ierr)
    4446            stop 'depth_sn'
    4447       endif
    4448 
    4449       ierr=NF_INQ_VARID(nid,"Ug",var3didin(3))
    4450          if(ierr/=NF_NOERR) then
    4451            write(*,*) NF_STRERROR(ierr)
    4452            stop 'Ug'
    4453       endif
    4454 
    4455       ierr=NF_INQ_VARID(nid,"Vg",var3didin(4))
    4456          if(ierr/=NF_NOERR) then
    4457            write(*,*) NF_STRERROR(ierr)
    4458            stop 'Vg'
    4459       endif
    4460        ierr=NF_INQ_VARID(nid,"pf",var3didin(5))
    4461          if(ierr/=NF_NOERR) then
    4462            write(*,*) NF_STRERROR(ierr)
    4463            stop 'pf'
    4464          endif
    4465 
    4466       ierr=NF_INQ_VARID(nid,"theta",var3didin(6))
    4467          if(ierr/=NF_NOERR) then
    4468            write(*,*) NF_STRERROR(ierr)
    4469            stop 'theta'
    4470          endif
    4471 
    4472       ierr=NF_INQ_VARID(nid,"tempe",var3didin(7))
    4473          if(ierr/=NF_NOERR) then
    4474            write(*,*) NF_STRERROR(ierr)
    4475            stop 'tempe'
    4476          endif
    4477 
    4478       ierr=NF_INQ_VARID(nid,"qv",var3didin(8))
    4479          if(ierr/=NF_NOERR) then
    4480            write(*,*) NF_STRERROR(ierr)
    4481            stop 'qv'
    4482          endif
    4483 
    4484       ierr=NF_INQ_VARID(nid,"u",var3didin(9))
    4485          if(ierr/=NF_NOERR) then
    4486            write(*,*) NF_STRERROR(ierr)
    4487            stop 'u'
    4488          endif
    4489 
    4490       ierr=NF_INQ_VARID(nid,"v",var3didin(10))
    4491          if(ierr/=NF_NOERR) then
    4492            write(*,*) NF_STRERROR(ierr)
    4493            stop 'v'
    4494          endif
    4495 
    4496       ierr=NF_INQ_VARID(nid,"hadvT",var3didin(11))
    4497          if(ierr/=NF_NOERR) then
    4498            write(*,*) NF_STRERROR(ierr)
    4499            stop 'hadvt'
    4500          endif
    4501 
    4502       ierr=NF_INQ_VARID(nid,"hadvQ",var3didin(12))
    4503          if(ierr/=NF_NOERR) then
    4504            write(*,*) NF_STRERROR(ierr)
    4505            stop 'hadvq'
    4506       endif
    4507 
    4508       ierr=NF_INQ_VARID(nid,"Tsnow",var3didin(14))
    4509          if(ierr/=NF_NOERR) then
    4510            write(*,*) NF_STRERROR(ierr)
    4511            stop 'tsnow'
    4512       endif
    4513 
    4514       ierr=NF_INQ_VARID(nid,"snow_density",var3didin(15))
    4515          if(ierr/=NF_NOERR) then
    4516            write(*,*) NF_STRERROR(ierr)
    4517            stop 'snow_density'
    4518       endif
    4519 
    4520       ierr=NF_INQ_VARID(nid,"Tg",var3didin(16))
    4521          if(ierr/=NF_NOERR) then
    4522            write(*,*) NF_STRERROR(ierr)
    4523            stop 'Tg'
    4524       endif
    4525 
    4526 
    4527 !dimensions lecture
    4528 !      call catchaxis(nid,ntime,nlevel,time,z,ierr)
    4529  
    4530 #ifdef NC_DOUBLE
    4531          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz_i)
    4532 #else
    4533          ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz_i)
    4534 #endif
    4535          if(ierr/=NF_NOERR) then
    4536             write(*,*) NF_STRERROR(ierr)
    4537             stop "getvarup"
    4538          endif
    4539  
    4540 #ifdef NC_DOUBLE
    4541          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),depth_sn)
    4542 #else
    4543          ierr = NF_GET_VAR_REAL(nid,var3didin(2),depth_sn)
    4544 #endif
    4545          if(ierr/=NF_NOERR) then
    4546             write(*,*) NF_STRERROR(ierr)
    4547             stop "getvarup"
    4548          endif
    4549  
    4550 #ifdef NC_DOUBLE
    4551          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),ug_i)
    4552 #else
    4553          ierr = NF_GET_VAR_REAL(nid,var3didin(3),ug_i)
    4554 #endif
    4555          if(ierr/=NF_NOERR) then
    4556             write(*,*) NF_STRERROR(ierr)
    4557             stop "getvarup"
    4558          endif
    4559  
    4560 #ifdef NC_DOUBLE
    4561          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),vg_i)
    4562 #else
    4563          ierr = NF_GET_VAR_REAL(nid,var3didin(4),vg_i)
    4564 #endif
    4565          if(ierr/=NF_NOERR) then
    4566             write(*,*) NF_STRERROR(ierr)
    4567             stop "getvarup"
    4568          endif
    4569  
    4570 #ifdef NC_DOUBLE
    4571          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),pf_i)
    4572 #else
    4573          ierr = NF_GET_VAR_REAL(nid,var3didin(5),pf_i)
    4574 #endif
    4575          if(ierr/=NF_NOERR) then
    4576             write(*,*) NF_STRERROR(ierr)
    4577             stop "getvarup"
    4578          endif
    4579 
    4580 #ifdef NC_DOUBLE
    4581          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),th_i)
    4582 #else
    4583          ierr = NF_GET_VAR_REAL(nid,var3didin(6),th_i)
    4584 #endif
    4585          if(ierr/=NF_NOERR) then
    4586             write(*,*) NF_STRERROR(ierr)
    4587             stop "getvarup"
    4588          endif
    4589 
    4590 #ifdef NC_DOUBLE
    4591          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),t_i)
    4592 #else
    4593          ierr = NF_GET_VAR_REAL(nid,var3didin(7),t_i)
    4594 #endif
    4595          if(ierr/=NF_NOERR) then
    4596             write(*,*) NF_STRERROR(ierr)
    4597             stop "getvarup"
    4598          endif
    4599 
    4600 #ifdef NC_DOUBLE
    4601          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),qv_i)
    4602 #else
    4603          ierr = NF_GET_VAR_REAL(nid,var3didin(8),qv_i)
    4604 #endif
    4605          if(ierr/=NF_NOERR) then
    4606             write(*,*) NF_STRERROR(ierr)
    4607             stop "getvarup"
    4608          endif
    4609  
    4610 #ifdef NC_DOUBLE
    4611          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),u_i)
    4612 #else
    4613          ierr = NF_GET_VAR_REAL(nid,var3didin(9),u_i)
    4614 #endif
    4615          if(ierr/=NF_NOERR) then
    4616             write(*,*) NF_STRERROR(ierr)
    4617             stop "getvarup"
    4618          endif
    4619  
    4620 #ifdef NC_DOUBLE
    4621          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),v_i)
    4622 #else
    4623          ierr = NF_GET_VAR_REAL(nid,var3didin(10),v_i)
    4624 #endif
    4625          if(ierr/=NF_NOERR) then
    4626             write(*,*) NF_STRERROR(ierr)
    4627             stop "getvarup"
    4628          endif
    4629  
    4630 #ifdef NC_DOUBLE
    4631          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),hadvt_i)
    4632 #else
    4633          ierr = NF_GET_VAR_REAL(nid,var3didin(11),hadvt_i)
    4634 #endif
    4635          if(ierr/=NF_NOERR) then
    4636             write(*,*) NF_STRERROR(ierr)
    4637             stop "getvarup"
    4638          endif
    4639  
    4640 #ifdef NC_DOUBLE
    4641          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),hadvq_i)
    4642 #else
    4643          ierr = NF_GET_VAR_REAL(nid,var3didin(12),hadvq_i)
    4644 #endif
    4645          if(ierr/=NF_NOERR) then
    4646             write(*,*) NF_STRERROR(ierr)
    4647             stop "getvarup"
    4648          endif
    4649  
    4650 #ifdef NC_DOUBLE
    4651          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),tsnow)
    4652 #else
    4653          ierr = NF_GET_VAR_REAL(nid,var3didin(14),tsnow)
    4654 #endif
    4655          if(ierr/=NF_NOERR) then
    4656             write(*,*) NF_STRERROR(ierr)
    4657             stop "getvarup"
    4658          endif
    4659  
    4660 #ifdef NC_DOUBLE
    4661          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),snow_dens)
    4662 #else
    4663          ierr = NF_GET_VAR_REAL(nid,var3didin(15),snow_dens)
    4664 #endif
    4665          if(ierr/=NF_NOERR) then
    4666             write(*,*) NF_STRERROR(ierr)
    4667             stop "getvarup"
    4668          endif
    4669 
    4670 #ifdef NC_DOUBLE
    4671          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),tg)
    4672 #else
    4673          ierr = NF_GET_VAR_REAL(nid,var3didin(16),tg)
    4674 #endif
    4675          if(ierr/=NF_NOERR) then
    4676             write(*,*) NF_STRERROR(ierr)
    4677             stop "getvarup"
    4678          endif
    4679 
    4680 ! On remet les variables lues dans le bon ordre des niveaux (MPL 20141024)
    4681          do k=1,nlevel
    4682            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          enddo
    4695          return
    4696  end subroutine read_gabls4
    4697 !=====================================================================
    4698 
    4699 !     Reads CIRC input files     
    4700 
    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 angle
    4715 !     sza= cosinus angle zenital
    4716       real wavn(ncm_1), ssf(ncm_1),za,sza
    4717       integer nlev
    4718 
    4719 
    4720 !     Open the files
    4721 
    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 information
    4730       do iskip=1,5
    4731          read (11, *)
    4732       enddo
    4733       read (11, '(i8)') nlev
    4734       read (11, '(f10.2)') tsfc
    4735       read (11, '(f10.2)') za
    4736       read (11, '(f10.4)') sw_dn_toa
    4737       sza=cos(za/180.*RPI)
    4738       print *,'nlev,tsfc,sza,sw_dn_toa,RPI',nlev,tsfc,sza,sw_dn_toa,RPI
    4739       close(11)
    4740 
    4741 !     Read level information
    4742       read (12, *)
    4743       do il=1,nlev
    4744          read (12, 302) ilev, z(il), p(il), t(il)
    4745          z(il)=z(il)*1000.    ! z donne en km
    4746          p(il)=p(il)*100.     ! p donne en mb
    4747       enddo
    4748 302   format (i8, f8.3, 2f9.2)
    4749       close(12)
    4750 
    4751 !     Read layer information (midpoint values)
    4752       do iskip=1,3
    4753          read (13, *)
    4754       enddo
    4755       do il=1,nlev-1
    4756          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       enddo
    4761 303   format (i8, 2f9.2, 10(2x,e13.7))     
    4762       close(13)
    4763      
    4764 !     Read aerosol layer information
    4765       do iskip=1,3
    4766          read (14, *)
    4767       enddo
    4768       read (14, '(f10.2)') aer_alpha
    4769       read (14, *)
    4770       read (14, *)
    4771       do il=1,nlev-1
    4772          read (14, 304) ilev, aer_beta(il), waer(il), gaer(il)
    4773       enddo
    4774 304   format (i8, f9.5, 2f8.3)
    4775       close(14)
    4776      
    4777 !     Read cloud information
    4778       do iskip=1,3
    4779          read (15, *)
    4780       enddo
    4781       do il=1,nlev-1
    4782          read (15, 305) ilev, cf(il), lwp(il), iwp(il), reliq(il), reice(il)
    4783          lwp(il)=lwp(il)/1000.          ! lwp donne en g/kg
    4784          iwp(il)=iwp(il)/1000.          ! iwp donne en g/kg
    4785          reliq(il)=reliq(il)/1000000.   ! reliq donne en microns
    4786          reice(il)=reice(il)/1000000.   ! reice donne en microns
    4787       enddo
    4788 305   format (i8, f8.3, 4f9.2)
    4789       close(15)
    4790 
    4791 !     Read surface albedo (weighted & unweighted) and spectral solar irradiance
    4792       do iskip=1,6
    4793          read (16, *)
    4794       enddo
    4795       do icm_1=1,ncm_1
    4796          read (16, 306) wavn(icm_1), albsfc(icm_1), albsfc_w(icm_1), ssf(icm_1)
    4797       enddo
    4798 306   format(f10.1, 2f12.5, f14.8)
    4799       close(16)
    4800  
    4801       return
    4802       end subroutine read_circ
    4803 !=====================================================================
    4804 !     Reads RTMIP input files     
    4805 
    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 nlev
    4813 
    4814 
    4815 !     Open the files
    4816 
    4817       open (11, file='low_resolution_profile.txt', status='old')
    4818      
    4819 !     Read level information
    4820       read (11, *)
    4821       do il=1,nlev_rtmip
    4822          read (11, 302) pt(il), pb(il), t(il),h2o(il),o3(il)
    4823       enddo
    4824       do il=1,nlev_rtmip
    4825          play(il)=pt(nlev_rtmip-il+1)*100.     ! p donne en mb
    4826          temp(il)=t(nlev_rtmip-il+1)
    4827          ovap(il)=h2o(nlev_rtmip-il+1)
    4828          oz(il)=o3(nlev_rtmip-il+1)
    4829       enddo
    4830       do il=1,39
    4831          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       enddo
    4834       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       return
    4839       end subroutine read_rtmip
    4840 !=====================================================================
    48411462
    48421463!  Subroutines for nudging
    … …  
    51271748       real frac,frac1,frac2,fact
    51281749 
    5129        do l = 1, llm
    5130        print *,'debut interp2, play=',l,play(l)
    5131        enddo
     1750!       do l = 1, llm
     1751!       print *,'debut interp2, play=',l,play(l)
     1752!       enddo
    51321753!      do l = 1, nlev_cas
    51331754!      print *,'debut interp2, plev_prof_cas=',l,play(l),plev_prof_cas(l)
    … …  
    51391760 
    51401761        mxcalc=l
    5141         print *,'debut interp2, mxcalc=',mxcalc
     1762!        print *,'debut interp2, mxcalc=',mxcalc
    51421763         k1=0
    51431764         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'
    6563        print*,                                                             &
    6574     & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=',     &
    … …  
    6607
    6618! 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                                       &
    83310!    &       ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas                           &
    83411     &       ,nt_cas,nlev_cas                                                               &
    … …  
    88461      d_u_dyn_z(:)=0.
    88562      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)
    89389      d_t_z(1)=d_t_z(2)
    89490      d_th_z(1)=d_th_z(2)
    … …  
    90298      d_v_z(llm)=d_v_z(llm-1)
    90399
     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
    904106!Calcul de l advection verticale
    905107! 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(:)
    911113
    912114!geostrophic wind
    … …  
    962164      do l = 1, llm
    963165! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309)
    964        omega(l) = omega_mod_cas(l)
    965166       omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
    966167       alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
    967168
    968169!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)
    1005180        endif
    1006181         
    … …  
    1025200       print *,'ust=',ust
    1026201      ENDIF
    1027       endif ! forcing_case2
    1028 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1029 

  • LMDZ6/trunk/libf/phylmd/dyn1d/1D_read_forc_cases.h

    r3537 r3541  
    1111      nq2=0
    1212
    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
    101514      if (forcing_SCM) then
    101615
    … …  
    102120!Time interpolation for initial conditions using interpolation routine
    102221         write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1   
    1023         CALL interp2_case_time(daytime,day1,annee_ref                                       &
     22        CALL interp_case_time_std(daytime,day1,annee_ref                                       &
    102423!    &       ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas                           &
    102524     &       ,nt_cas,nlev_cas                                                               &

  • LMDZ6/trunk/libf/phylmd/dyn1d/lmdz1d.F90

    r3540 r3541  
    99
    1010
    11       PROGRAM lmdz1d
     11   PROGRAM lmdz1d
    1212
    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
    3314
    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
    5016
    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)
    5818
    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
    6624
    67 !=====================================================================
    68 ! DECLARATIONS
    69 !=====================================================================
     25   END
    7026
    71 !---------------------------------------------------------------------
    72 !  Externals
    73 !---------------------------------------------------------------------
    74       external fq_sat
    75       real fq_sat
    76 
    77 !---------------------------------------------------------------------
    78 !  Arguments d' initialisations de la physique (USER DEFINE)
    79 !---------------------------------------------------------------------
    80 
    81       integer, parameter :: ngrid=1
    82       real :: zcufi    = 1.
    83       real :: zcvfi    = 1.
    84 
    85 !-      real :: nat_surf
    86 !-      logical :: ok_flux_surf
    87 !-      real :: fsens
    88 !-      real :: flat
    89 !-      real :: tsurf
    90 !-      real :: rugos
    91 !-      real :: qsol(1:2)
    92 !-      real :: qsurf
    93 !-      real :: psurf
    94 !-      real :: zsurf
    95 !-      real :: albedo
    96 !-
    97 !-      real :: time     = 0.
    98 !-      real :: time_ini
    99 !-      real :: xlat
    100 !-      real :: xlon
    101 !-      real :: wtsurf
    102 !-      real :: wqsurf
    103 !-      real :: restart_runoff
    104 !-      real :: xagesno
    105 !-      real :: qsolinp
    106 !-      real :: zpicinp
    107 !-
    108       real :: fnday
    109       real :: day, daytime
    110       real :: day1
    111       real :: heure
    112       integer :: jour
    113       integer :: mois
    114       integer :: an
    115  
    116 !---------------------------------------------------------------------
    117 !  Declarations related to forcing and initial profiles
    118 !---------------------------------------------------------------------
    119 
    120         integer :: kmax = llm
    121         integer llm700,nq1,nq2
    122         INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
    123         real timestep, frac
    124         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_type
    132         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 file
    151 !                                                            (cf read_tsurf1d.F)
    152 
    153 real wwww
    154 !vertical advection computation
    155 !       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 zfact
    159 
    160 !flag forcings
    161         logical :: nudge_wind=.true.
    162         logical :: nudge_thermo=.false.
    163         logical :: cptadvw=.true.
    164 !=====================================================================
    165 ! DECLARATIONS FOR EACH CASE
    166 !=====================================================================
    167 !
    168 #include "1D_decl_cases.h"
    169 !
    170 !---------------------------------------------------------------------
    171 !  Declarations related to nudging
    172 !---------------------------------------------------------------------
    173      integer :: nudge_max
    174      parameter (nudge_max=9)
    175      integer :: inudge_RHT=1
    176      integer :: inudge_UV=2
    177      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.e5
    187       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 variables
    192 !---------------------------------------------------------------------
    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-1
    197       real :: rlat_rad(1),rlon_rad(1)
    198       real :: omega(llm+1),omega2(llm),rho(llm+1)
    199       real :: ug(llm),vg(llm),fcoriolis
    200       real :: sfdt, cfdt
    201       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 :: alpha
    208       real :: ttt
    209 
    210       REAL, ALLOCATABLE, DIMENSION(:,:):: q
    211       REAL, ALLOCATABLE, DIMENSION(:,:):: dq
    212       REAL, ALLOCATABLE, DIMENSION(:,:):: dq_dyn
    213       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
    214       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
    215 !      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
    216 
    217 !---------------------------------------------------------------------
    218 !  Initialization of surface variables
    219 !---------------------------------------------------------------------
    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 phyredem
    227 !---------------------------------------------------------------------
    228       logical :: ok_writedem =.true.
    229       real :: sollw_in = 0.
    230       real :: solsw_in = 0.
    231      
    232 !---------------------------------------------------------------------
    233 !  Call to physiq
    234 !---------------------------------------------------------------------
    235       logical :: firstcall=.true.
    236       logical :: lastcall=.false.
    237       real :: phis(1)    = 0.0
    238       real :: dpsrf(1)
    239 
    240 !---------------------------------------------------------------------
    241 !  Initializations of boundary conditions
    242 !---------------------------------------------------------------------
    243       real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
    244       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_ocean
    247       real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
    248       real, allocatable :: phy_ice (:) ! Fraction de glace
    249       real, allocatable :: phy_fter(:) ! Fraction de terre
    250       real, allocatable :: phy_foce(:) ! Fraction de ocean
    251       real, allocatable :: phy_fsic(:) ! Fraction de glace
    252       real, allocatable :: phy_flic(:) ! Fraction de glace
    253 
    254 !---------------------------------------------------------------------
    255 !  Fichiers et d'autres variables
    256 !---------------------------------------------------------------------
    257       integer :: k,l,i,it=1,mxcalc
    258       integer :: nsrf
    259       integer jcode
    260       INTEGER read_climoz
    261 !
    262       integer :: it_end ! iteration number of the last call
    263 !Al1
    264       integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
    265       data ecrit_slab_oc/-1/
    266 !
    267 !     if flag_inhib_forcing = 0, tendencies of forcing are added
    268 !                           <> 0, tendencies of forcing are not added
    269       INTEGER :: flag_inhib_forcing = 0
    270 
    271 !=====================================================================
    272 ! INITIALIZATIONS
    273 !=====================================================================
    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_forcing
    289        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 !Al1
    301         call conf_unicol
    302 !Al1 moves this gcssold var from common fcg_gcssold to
    303         Turb_fcg_gcssold = xTurb_fcg_gcssold
    304 ! --------------------------------------------------------------------
    305         close(1)
    306 !Al1
    307         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.001
    312 !             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 cooling
    317 !             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 files
    321 !             LS convergence and SST imposed from TOGA-COARE IFA files
    322 !forcing_type = 3 ==> forcing_GCM2SCM = .true.
    323 !             initial profiles from the GCM output
    324 !             LS convergence imposed from the GCM output
    325 !forcing_type = 4 ==> forcing_twpice = .true.
    326 !             initial profiles from TWP-ICE cdf file
    327 !             LS convergence, omega and SST imposed from TWP-ICE files
    328 !forcing_type = 5 ==> forcing_rico = .true.
    329 !             initial profiles from RICO files
    330 !             LS convergence imposed from RICO files
    331 !forcing_type = 6 ==> forcing_amma = .true.
    332 !             initial profiles from AMMA nc file
    333 !             LS convergence, omega and surface fluxes imposed from AMMA file 
    334 !forcing_type = 7 ==> forcing_dice = .true.
    335 !             initial profiles and large scale forcings in dice_driver.nc
    336 !             Different stages: soil model alone, atm. model alone
    337 !             then both models coupled
    338 !forcing_type = 8 ==> forcing_gabls4 = .true.
    339 !             initial profiles and large scale forcings in gabls4_driver.nc
    340 !forcing_type >= 100 ==> forcing_case = .true.
    341 !             initial profiles and large scale forcings in cas.nc
    342 !             LS convergence, omega and SST imposed from CINDY-DYNAMO files
    343 !             101=cindynamo
    344 !             102=bomex
    345 !forcing_type >= 100 ==> forcing_case2 = .true.
    346 !             temporary flag while all the 1D cases are not whith the same cas.nc forcing file
    347 !             103=arm_cu2 ie arm_cu with new forcing format
    348 !             104=rico2 ie rico with new forcing format
    349 !forcing_type = 40 ==> forcing_GCSSold = .true.
    350 !             initial profile from GCSS file
    351 !             LS convergence imposed from GCSS file
    352 !forcing_type = 50 ==> forcing_fire = .true.
    353 !             forcing from fire.nc
    354 !forcing_type = 59 ==> forcing_sandu = .true.
    355 !             initial profiles from sanduref file: see prof.inp.001
    356 !             SST varying with time and divergence constante: see ifa_sanduref.txt file
    357 !             Radiation has to be computed interactively
    358 !forcing_type = 60 ==> forcing_astex = .true.
    359 !             initial profiles from file: see prof.inp.001
    360 !             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
    361 !             Radiation has to be computed interactively
    362 !forcing_type = 61 ==> forcing_armcu = .true.
    363 !             initial profiles from file: see prof.inp.001
    364 !             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
    365 !             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
    366 !             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s
    367 !             Radiation to be switched off
    368 !
    369       if (forcing_type <=0) THEN
    370        forcing_les = .true.
    371       elseif (forcing_type .eq.1) THEN
    372        forcing_radconv = .true.
    373       elseif (forcing_type .eq.2) THEN
    374        forcing_toga    = .true.
    375       elseif (forcing_type .eq.3) THEN
    376        forcing_GCM2SCM = .true.
    377       elseif (forcing_type .eq.4) THEN
    378        forcing_twpice = .true.
    379       elseif (forcing_type .eq.5) THEN
    380        forcing_rico = .true.
    381       elseif (forcing_type .eq.6) THEN
    382        forcing_amma = .true.
    383       elseif (forcing_type .eq.7) THEN
    384        forcing_dice = .true.
    385       elseif (forcing_type .eq.8) THEN
    386        forcing_gabls4 = .true.
    387       elseif (forcing_type .eq.101) THEN ! Cindynamo starts 1-10-2011 0h
    388        forcing_case = .true.
    389        year_ini_cas=2011
    390        mth_ini_cas=10
    391        day_deb=1
    392        heure_ini_cas=0.
    393        pdt_cas=3*3600.         ! forcing frequency
    394       elseif (forcing_type .eq.102) THEN ! Bomex starts 24-6-1969 0h
    395        forcing_case = .true.
    396        year_ini_cas=1969
    397        mth_ini_cas=6
    398        day_deb=24
    399        heure_ini_cas=0.
    400        pdt_cas=1800.         ! forcing frequency
    401       elseif (forcing_type .eq.103) THEN ! Arm_cu starts 21-6-1997 11h30
    402        forcing_case2 = .true.
    403        year_ini_cas=1997
    404        mth_ini_cas=6
    405        day_deb=21
    406        heure_ini_cas=11.5
    407        pdt_cas=1800.         ! forcing frequency
    408       elseif (forcing_type .eq.104) THEN ! rico starts 16-12-2004 0h
    409        forcing_case2 = .true.
    410        year_ini_cas=2004
    411        mth_ini_cas=12
    412        day_deb=16
    413        heure_ini_cas=0.
    414        pdt_cas=1800.         ! forcing frequency
    415       elseif (forcing_type .eq.105) THEN ! bomex starts 16-12-2004 0h
    416        forcing_case2 = .true.
    417        year_ini_cas=1969
    418        mth_ini_cas=6
    419        day_deb=24
    420        heure_ini_cas=0.
    421        pdt_cas=1800.         ! forcing frequency
    422       elseif (forcing_type .eq.106) THEN ! ayotte_24SC starts 6-11-1992 0h
    423        forcing_case2 = .true.
    424        year_ini_cas=1992
    425        mth_ini_cas=11
    426        day_deb=6
    427        heure_ini_cas=10.
    428        pdt_cas=86400.        ! forcing frequency
    429       elseif (forcing_type .eq.113) THEN ! Arm_cu starts 21-6-1997 11h30
    430        forcing_SCM = .true.
    431        year_ini_cas=1997
    432        mth_ini_cas=6
    433        day_deb=21
    434        heure_ini_cas=11.5
    435        pdt_cas=1800.         ! forcing frequency
    436       elseif (forcing_type .eq.40) THEN
    437        forcing_GCSSold = .true.
    438       elseif (forcing_type .eq.50) THEN
    439        forcing_fire = .true.
    440       elseif (forcing_type .eq.59) THEN
    441        forcing_sandu   = .true.
    442       elseif (forcing_type .eq.60) THEN
    443        forcing_astex   = .true.
    444       elseif (forcing_type .eq.61) THEN
    445        forcing_armcu = .true.
    446        IF(llm.NE.19.AND.llm.NE.40) stop 'Erreur nombre de niveaux !!'
    447       else
    448        write (*,*) 'ERROR : unknown forcing_type ', forcing_type
    449        stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'
    450       ENDIF
    451       print*,"forcing type=",forcing_type
    452 
    453 ! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time
    454 ! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature
    455 ! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F
    456 ! through the common sst_forcing.
    457 
    458         type_ts_forcing = 0
    459         if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice)                 &
    460      &    type_ts_forcing = 1
    461 !
    462 ! Initialization of the logical switch for nudging
    463      jcode = iflag_nudge
    464      do i = 1,nudge_max
    465        nudge(i) = mod(jcode,10) .ge. 1
    466        jcode = jcode/10
    467      enddo
    468 !---------------------------------------------------------------------
    469 !  Definition of the run
    470 !---------------------------------------------------------------------
    471 
    472       call conf_gcm( 99, .TRUE. )
    473      
    474 !-----------------------------------------------------------------------
    475       allocate( phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
    476       phy_nat(:)=0.0
    477       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_ocean
    480       phy_bil(:)=1.0
    481       allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
    482       allocate( phy_ice (year_len)) ! Fraction de glace
    483       phy_ice(:)=0.0
    484       allocate( phy_fter(year_len)) ! Fraction de terre
    485       phy_fter(:)=0.0
    486       allocate( phy_foce(year_len)) ! Fraction de ocean
    487       phy_foce(:)=0.0
    488       allocate( phy_fsic(year_len)) ! Fraction de glace
    489       phy_fsic(:)=0.0
    490       allocate( phy_flic(year_len)) ! Fraction de glace
    491       phy_flic(:)=0.0
    492 !-----------------------------------------------------------------------
    493 !   Choix du calendrier
    494 !   -------------------
    495 
    496 !      calend = 'earth_365d'
    497       if (calend == 'earth_360d') then
    498         call ioconf_calendar('360d')
    499         write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
    500       else if (calend == 'earth_365d') then
    501         call ioconf_calendar('noleap')
    502         write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
    503       else if (calend == 'earth_366d') then
    504         call ioconf_calendar('all_leap')
    505         write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
    506       else if (calend == 'gregorian') then
    507         stop 'gregorian calend should not be used by normal user'
    508         call ioconf_calendar('gregorian') ! not to be used by normal users
    509         write(*,*)'CALENDRIER CHOISI: Gregorien'
    510       else
    511         write (*,*) 'ERROR : unknown calendar ', calend
    512         stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
    513       endif
    514 !-----------------------------------------------------------------------
    515 !
    516 !c Date :
    517 !      La date est supposee donnee sous la forme [annee, numero du jour dans
    518 !      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) then
    523          fnday=nday
    524       else
    525          fnday=-nday/float(day_step)
    526       endif
    527       print *,'fnday=',fnday
    528 !     start_time doit etre en FRACTION DE JOUR
    529       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 = anneeref
    539       mois = 1
    540       day_ref = dayref
    541       heure = 0.
    542       itau_dyn = 0
    543       itau_phy = 0
    544       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) THEN
    549 ! Convert the initial date of Toga-Coare to Julian day
    550       call ymds2ju                                                          &
    551      & (year_ini_toga,mth_ini_toga,day_ini_toga,heure,day_ju_ini_toga)
    552 
    553       ELSEIF (forcing_type .eq.4) THEN
    554 ! Convert the initial date of TWPICE to Julian day
    555       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) THEN
    559 ! Convert the initial date of AMMA to Julian day
    560       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) THEN
    564 ! Convert the initial date of DICE to Julian day
    565       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 ) THEN
    569 ! Convert the initial date of GABLS4 to Julian day
    570       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) THEN
    574 ! Convert the initial date to Julian day
    575       day_ini_cas=day_deb
    576       print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
    577       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_cas
    581       ELSEIF (forcing_type .eq.59) THEN
    582 ! Convert the initial date of Sandu case to Julian day
    583       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) THEN
    588 ! Convert the initial date of Astex case to Julian day
    589       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) THEN
    594 ! Convert the initial date of Arm_cu case to Julian day
    595       call ymds2ju                                                          &
    596      & (year_ini_armcu,mth_ini_armcu,day_ini_armcu,heure_ini_armcu          &
    597      & ,day_ju_ini_armcu)
    598       ENDIF
    599 
    600       IF (forcing_type .gt.100) THEN
    601       daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation
    602       ELSE
    603       daytime = day + time_ini/24. ! 1st day and initial time of the simulation
    604       ENDIF
    605 ! 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_print
    609 
    610 !---------------------------------------------------------------------
    611 ! Initialization of dimensions, geometry and initial state
    612 !---------------------------------------------------------------------
    613 !      call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
    614 !     but we still need to initialize dimphy module (klon,klev,etc.)  here.
    615       call init_dimphy1D(1,llm)
    616       call suphel
    617       call infotrac_init
    618 
    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-initialization
    635 !          (phys_state_var_init is called again in physiq)
    636       read_climoz = 0
    637 !
    638       call phys_state_var_init(read_climoz)
    639 
    640       if (ngrid.ne.klon) then
    641          print*,'stop in inifis'
    642          print*,'Probleme de dimensions :'
    643          print*,'ngrid = ',ngrid
    644          print*,'klon  = ',klon
    645          stop
    646       endif
    647 !!!=====================================================================
    648 !!! Feedback forcing values for Gateaux differentiation (al1)
    649 !!!=====================================================================
    650 !!! Surface Planck forcing bracketing call radiation
    651 !!      surf_Planck = 0.
    652 !!      surf_Conv   = 0.
    653 !!      write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv
    654 !!! a mettre dans le lmdz1d.def ou autre
    655 !!
    656 !!
    657       qsol = qsolinp
    658       qsurf = fq_sat(tsurf,psurf/100.)
    659       day1= day_ini
    660       time=daytime-day
    661       ts_toga(1)=tsurf ! needed by read_tsurf1d.F
    662       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 marchent
    667       IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
    668        fsens=-wtsurf*rcpd*rho(1)
    669        flat=-wqsurf*rlvtt*rho(1)
    670        print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
    671       ENDIF
    672       print*,'Flux sol ',fsens,flat
    673 !!      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   = 5e4
    681 !!      preff= 1.01325e5
    682       preff = psurf
    683       IF (ok_old_disvert) THEN
    684         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       ELSE
    691         call disvert()
    692         print *,'On utilise disvert'
    693 !       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
    694 !       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
    695       ENDIF
    696 
    697       sig_s=presnivs/preff
    698       plev =ap+bp*psurf
    699       play = 0.5*(plev(1:llm)+plev(2:llm+1))
    700       zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles
    701 
    702       IF (forcing_type .eq. 59) THEN
    703 ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
    704       write(*,*) '***********************'
    705       do l = 1, llm
    706        write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
    707        if (trouve_700 .and. play(l).le.70000) then
    708          llm700=l
    709          print *,'llm700,play=',llm700,play(l)/100.
    710          trouve_700= .false.
    711        endif
    712       enddo
    713       write(*,*) '***********************'
    714       ENDIF
    715 
    716 !
    717 !=====================================================================
    718 ! EVENTUALLY, READ FORCING DATA :
    719 !=====================================================================
    720 
    721 #include "1D_read_forc_cases.h"
    722 
    723       if (forcing_GCM2SCM) then
    724         write (*,*) 'forcing_GCM2SCM not yet implemented'
    725         stop 'in initialization'
    726       endif ! forcing_GCM2SCM
    727 
    728       print*,'mxcalc=',mxcalc
    729 !     print*,'zlay=',zlay(mxcalc)
    730       print*,'play=',play(mxcalc)
    731 
    732 !Al1 pour SST forced, appell?? depuis ocean_forced_noice
    733       ts_cur = tsurf ! SST used in read_tsurf1d
    734 !=====================================================================
    735 ! Initialisation de la physique :
    736 !=====================================================================
    737 
    738 !  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
    739 !
    740 ! day_step, iphysiq lus dans gcm.def ci-dessus
    741 ! timestep: calcule ci-dessous from rday et day_step
    742 ! ngrid=1
    743 ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
    744 ! 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 programme
    748 ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
    749       day_step = float(nsplit_phys)*day_step/float(iphysiq)
    750       write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
    751       timestep =rday/day_step
    752       dtime_frcg = timestep
    753 !
    754       zcufi=airefi
    755       zcvfi=airefi
    756 !
    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_mod
    761      year_len_phys_cal_mod=year_len
    762            
    763      ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
    764      ! e.g. for cell boundaries, which are meaningless in 1D; so pad these
    765      ! with '0.' when necessary
    766       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.0
    779       solaire=1370.0
    780 
    781 ! Ecriture du startphy avant le premier appel a la physique.
    782 ! On le met juste avant pour avoir acces a tous les champs
    783 
    784       if (ok_writedem) then
    785 
    786 !--------------------------------------------------------------------------
    787 ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
    788 ! need : qsol fder snow qsurf evap rugos agesno ftsoil
    789 !--------------------------------------------------------------------------
    790 
    791         type_ocean = "force"
    792         run_off_lic_0(1) = restart_runoff
    793         call fonte_neige_init(run_off_lic_0)
    794 
    795         fder=0.
    796         snsrf(1,:)=snowmass ! masse de neige des sous surface
    797         qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
    798         fevap=0.
    799         z0m(1,:)=rugos     ! couverture de neige des sous surface
    800         z0h(1,:)=rugosh    ! couverture de neige des sous surface
    801         agesno  = xagesno
    802         tsoil(:,:,:)=tsurf
    803 !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
    804 !       tsoil(1,1,1)=299.18
    805 !       tsoil(1,2,1)=300.08
    806 !       tsoil(1,3,1)=301.88
    807 !       tsoil(1,4,1)=305.48
    808 !       tsoil(1,5,1)=308.00
    809 !       tsoil(1,6,1)=308.00
    810 !       tsoil(1,7,1)=308.00
    811 !       tsoil(1,8,1)=308.00
    812 !       tsoil(1,9,1)=308.00
    813 !       tsoil(1,10,1)=308.00
    814 !       tsoil(1,11,1)=308.00
    815 !-----------------------------------------------------------------------
    816         call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
    817 
    818 !------------------ prepare limit conditions for limit.nc -----------------
    819 !--   Ocean force
    820 
    821         print*,'avant phyredem'
    822         pctsrf(1,:)=0.
    823           if (nat_surf.eq.0.) then
    824           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) then
    829           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) then
    834           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) then
    839           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 if
    845 
    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 = zpicinp
    852         ftsol=tsurf
    853         nsw=6 ! on met le nb de bandes SW=6, pour initialiser
    854               ! 6 albedo, mais on peut quand meme tourner avec
    855               ! moins. Seules les 2 ou 4 premiers seront lus
    856         falb_dir=albedo
    857         falb_dif=albedo
    858         rugoro=rugos
    859         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-8
    868         pbl_tke(:,:,:)=0.
    869         pbl_tke(:,2,:)=1.e-2
    870         PRINT *, ' pbl_tke dans lmdz1d '
    871         if (prt_level .ge. 5) then
    872          DO nsrf = 1,4
    873            PRINT *,'pbl_tke(1,:,',nsrf,') ',pbl_tke(1,:,nsrf)
    874          ENDDO
    875         end if
    876 
    877 !>jyg
    878 
    879         rain_fall=0.
    880         snow_fall=0.
    881         solsw=0.
    882         sollw=0.
    883         sollwdown=rsigma*tsurf**4
    884         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,rugoro
    927 ! 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,w01
    929 ! 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 in
    933 ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have
    934 ! to be set at some arbitratry convenient values.
    935 !------------------------------------------------------------------------
    936 !Al1 =============== restart option ==========================
    937         if (.not.restart) then
    938           iflag_pbl = 5
    939           call phyredem ("startphy.nc")
    940         else
    941 ! (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         endif
    947 
    948         ok_writedem=.false.
    949         print*,'apres phyredem'
    950 
    951       endif ! ok_writedem
    952      
    953 !------------------------------------------------------------------------
    954 ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
    955 ! --------------------------------------------------
    956 ! NB: List of the variables to be written in limit.nc
    957 !     (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_len
    962         phy_nat(i)  = nat_surf
    963         phy_alb(i)  = albedo
    964         phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
    965         phy_rug(i)  = rugos
    966         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       enddo
    971 
    972 ! fabrication de limit.nc
    973       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_end
    978 !Al1
    979       if (restart) then
    980         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_ini
    986 !**      call ymds2ju(annee_ref,mois,day_ini,heure,day)
    987        day = day_ini
    988        day_end = day_ini + nday
    989        daytime = day + time_ini/24. ! 1st day and initial time of the simulation
    990 
    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-day
    997  
    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),phis
    1002 ! raz for safety
    1003        do l=1,llm
    1004          dq_dyn(l,1) = 0.
    1005        enddo
    1006       endif
    1007 !Al1 ================  end restart =================================
    1008       IF (ecrit_slab_oc.eq.1) then
    1009          open(97,file='div_slab.dat',STATUS='UNKNOWN')
    1010        elseif (ecrit_slab_oc.eq.0) then
    1011          open(97,file='div_slab.dat',STATUS='OLD')
    1012        endif
    1013 !
    1014 !---------------------------------------------------------------------
    1015 !    Initialize target profile for RHT nudging if needed
    1016 !---------------------------------------------------------------------
    1017       if (nudge(inudge_RHT)) then
    1018         call nudge_RHT_init(plev,play,temp,q(:,1),t_targ,rh_targ)
    1019       endif
    1020       if (nudge(inudge_UV)) then
    1021         call nudge_UV_init(plev,play,u,v,u_targ,v_targ)
    1022       endif
    1023 !
    1024 !=====================================================================
    1025        CALL iophys_ini
    1026 ! START OF THE TEMPORAL LOOP :
    1027 !=====================================================================
    1028            
    1029       it_end = nint(fnday*day_step)
    1030 !test JLD     it_end = 10
    1031       do while(it.le.it_end)
    1032 
    1033        if (prt_level.ge.1) then
    1034          print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
    1035      &             it,day,time,it_end,day_step
    1036          print*,'PAS DE TEMPS ',timestep
    1037        endif
    1038 !Al1 demande de restartphy.nc
    1039        if (it.eq.it_end) lastcall=.True.
    1040 
    1041 !---------------------------------------------------------------------
    1042 ! Interpolation of forcings in time and onto model levels
    1043 !---------------------------------------------------------------------
    1044 
    1045 #include "1D_interp_cases.h"
    1046 
    1047       if (forcing_GCM2SCM) then
    1048         write (*,*) 'forcing_GCM2SCM not yet implemented'
    1049         stop 'in time loop'
    1050       endif ! forcing_GCM2SCM
    1051 
    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-1
    1058           phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
    1059      &    (play(l)-play(l+1))/(play(l)+play(l+1))
    1060         enddo
    1061 
    1062 !---------------------------------------------------------------------
    1063 ! Listing output for debug prt_level>=1
    1064 !---------------------------------------------------------------------
    1065        if (prt_level>=1) then
    1066          print *,' avant physiq : -------- day time ',day,time
    1067          write(*,*) 'firstcall,lastcall,phis',                               &
    1068      &               firstcall,lastcall,phis
    1069        end if
    1070        if (prt_level>=5) then
    1071          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        endif
    1080 
    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 debug
    1093 !---------------------------------------------------------------------
    1094         if (prt_level>=5) then
    1095           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',dpsrf
    1109         endif
    1110 !---------------------------------------------------------------------
    1111 !   Add physical tendencies :
    1112 !---------------------------------------------------------------------
    1113 
    1114        fcoriolis=2.*sin(rpi*xlat/180.)*romega
    1115        if (forcing_radconv .or. forcing_fire) then
    1116          fcoriolis=0.0
    1117          dt_cooling=0.0
    1118          d_t_adv=0.0
    1119          d_q_adv=0.0
    1120        endif
    1121 !      print*, 'calcul de fcoriolis ', fcoriolis
    1122 
    1123        if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
    1124      &    .or.forcing_amma .or. forcing_type.eq.101) then
    1125          fcoriolis=0.0 ; ug=0. ; vg=0.
    1126        endif
    1127 
    1128        if(forcing_rico) then
    1129           dt_cooling=0.
    1130        endif
    1131 
    1132 !CRio:Attention modif sp??cifique cas de Caroline
    1133       if (forcing_type==-1) then
    1134          fcoriolis=0.
    1135 !Nudging
    1136        
    1137 !on calcule dt_cooling
    1138         do l=1,llm
    1139         if (play(l).ge.20000.) then
    1140             dt_cooling(l)=-1.5/86400.
    1141         elseif ((play(l).ge.10000.).and.((play(l).lt.20000.))) then
    1142             dt_cooling(l)=-1.5/86400.*(play(l)-10000.)/(10000.)-1./86400.*(20000.-play(l))/10000.*(temp(l)-200.)
    1143         else
    1144             dt_cooling(l)=-1.*(temp(l)-200.)/86400.
    1145         endif
    1146         enddo
    1147 
    1148       endif     
    1149 !RC
    1150       if (forcing_sandu) then
    1151          ug(1:llm)=u_mod(1:llm)
    1152          vg(1:llm)=v_mod(1:llm)
    1153       endif
    1154 
    1155       IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &
    1156                                    fcoriolis, xlat,mxcalc
    1157 
    1158 !       print *,'u-ug=',u-ug
    1159 
    1160 !!!!!!!!!!!!!!!!!!!!!!!!
    1161 ! Geostrophic wind
    1162 ! Le calcul ci dessous est insuffisamment precis
    1163 !      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,timestep
    1169 !
    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 !  Nudging
    1182 !!!!!!!!!!!!!!!!!!!!!!!!
    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)) then
    1188         call nudge_RHT(timestep,plev,play,t_targ,rh_targ,temp,q(:,1),     &
    1189     &                  d_t_nudge,d_q_nudge(:,1))
    1190       endif
    1191       if (nudge(inudge_UV)) then
    1192         call nudge_UV(timestep,plev,play,u_targ,v_targ,u,v,     &
    1193     &                  d_u_nudge,d_v_nudge)
    1194       endif
    1195 !
    1196        if (forcing_fire) THEN
    1197 
    1198 !let ww=if ( alt le 1100 ) then alt*-0.00001 else 0
    1199 !let wt=if ( alt le 1100 ) then min( -3.75e-5 , -7.5e-8*alt)  else 0
    1200 !let wq=if ( alt le 1100 ) then max( 1.5e-8 , 3e-11*alt)  else 0
    1201            d_t_adv=0.
    1202            d_q_adv=0.
    1203            teta=temp*(pzero/play)**rkappa
    1204            d_t_adv=0.
    1205            d_q_adv=0.
    1206            do l=2,llm-1
    1207               if (zlay(l)<=1100) then
    1208                   wwww=-0.00001*zlay(l)
    1209                   d_t_adv(l)=-wwww*(teta(l)-teta(l+1))/(zlay(l)-zlay(l+1)) /(pzero/play(l))**rkappa
    1210                   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               endif
    1214            enddo
    1215 
    1216         endif
    1217 
    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 variables
    1227 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1228     IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
    1229 
    1230 ! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h
    1231 ! au dessus de 700hpa, on relaxe vers les profils initiaux
    1232       if (forcing_sandu .OR. forcing_astex) then
    1233 #include "1D_nudge_sandu_astex.h"
    1234       else
    1235         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) then
    1249           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_phys
    1253            print* ,'dv_age=',dv_age
    1254            print* ,'dv_adv=',dv_adv
    1255            print* ,'d_v_nudge=',d_v_nudge
    1256            print*, v
    1257            print*, vg
    1258         endif
    1259 
    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_astex
    1267 
    1268         teta=temp*(pzero/play)**rkappa
    1269 !
    1270 !---------------------------------------------------------------------
    1271 !   Nudge soil temperature if requested
    1272 !---------------------------------------------------------------------
    1273 
    1274       IF (nudge_tsoil .AND. .NOT. lastcall) THEN
    1275        ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
    1276      &  -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
    1277       ENDIF
    1278 
    1279 !---------------------------------------------------------------------
    1280 !   Add large-scale tendencies (advection, etc) :
    1281 !---------------------------------------------------------------------
    1282 
    1283 !cc nrlmd
    1284 !cc        tmpvar=teta
    1285 !cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
    1286 !cc
    1287 !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 added
    1296 
    1297 !---------------------------------------------------------------------
    1298 !   Air temperature :
    1299 !---------------------------------------------------------------------       
    1300         if (lastcall) then
    1301           print*,'Pas de temps final ',it
    1302           call ju2ymds(daytime, an, mois, jour, heure)
    1303           print*,'a la date : a m j h',an, mois, jour ,heure/3600.
    1304         endif
    1305 
    1306 !  incremente day time
    1307 !        print*,'daytime bef',daytime,1./day_step
    1308         daytime = daytime+1./day_step
    1309 !Al1dbg
    1310         day = int(daytime+0.1/day_step)
    1311 !        time = max(daytime-day,0.0)
    1312 !Al1&jyg: correction de bug
    1313 !cc        time = real(mod(it,day_step))/day_step
    1314         time = time_ini/24.+real(mod(it,day_step))/day_step
    1315 !        print*,'daytime nxt time',daytime,time
    1316         it=it+1
    1317 
    1318       enddo
    1319 
    1320 !Al1
    1321       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       end
    133227
    133328#include "1DUTILS.h"

  • LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.F90

    r3538 r3541  
    320320
    321321#include "netcdf.inc"
     322#include "date_cas.h"
    322323
    323324      INTEGER nid,rid,ierr
    324       INTEGER ii,jj
     325      INTEGER ii,jj,timeid
     326      REAL, ALLOCATABLE :: time_val(:)
    325327
    326328      print*,'ON EST VRAIMENT LA'
    … …  
    349351      print*,'OK2 read2: nid,rid,lat',nid,rid,jj
    350352!.......................................................................
    351       ierr=NF_INQ_DIMID(nid,'nlev',rid)
     353      ierr=NF_INQ_DIMID(nid,'lev',rid)
    352354      IF (ierr.NE.NF_NOERR) THEN
    353355         print*, 'Oh probleme lecture dimension nlev'
    … …  
    355357      ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
    356358      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
    357363!.......................................................................
    358364      ierr=NF_INQ_DIMID(nid,'time',rid)
    … …  
    363369      ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
    364370      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
    365394
    366395!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    949978!-----------------------------------------------------------------------
    950979         select case(i)
    951            case(1) ; ap=apbp       ! donnees indexees en nlevel+1
    952            case(2) ; bp=apbp
     980         !case(1) ; ap=apbp       ! donnees indexees en nlevel+1
     981         ! case(2) ; bp=apbp
    953982           case(3) ; zzh=apbp
    954983           case(4) ; pph=apbp
Note: See TracChangeset for help on using the changeset viewer.