Ignore:
Timestamp:
Nov 21, 2019, 4:43:45 PM (5 years ago)
Author:
lguez
Message:

Merge revisions 3427:3600 of trunk into branch Ocean_skin

Location:
LMDZ6/branches/Ocean_skin
Files:
9 edited
7 copied

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Ocean_skin

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1DUTILS.h

    • Property svn:keywords set to Id
    r3316 r3605  
    22
    33!
    4 ! $Id: conf_unicol.F 1279 2010-08-04 17:20:56Z lahellec $
     4! $Id$
    55!
    66!
    … …  
    540540       CALL getin('nudging_w',nudging_w)
    541541
     542! RELIQUE ANCIENS FORMAT. ECRASE PAR LE SUIVANT
    542543!Config  Key  = nudging_q
    543544!Config  Desc = forcage ou non par nudging sur q
    544545!Config  Def  = false
    545546!Config  Help = forcage ou non par nudging sur q
    546        nudging_q =0
    547        CALL getin('nudging_q',nudging_q)
     547       nudging_qv =0
     548       CALL getin('nudging_q',nudging_qv)
     549       CALL getin('nudging_qv',nudging_qv)
     550
     551       p_nudging_u=11000.
     552       p_nudging_v=11000.
     553       p_nudging_t=11000.
     554       p_nudging_qv=11000.
     555       CALL getin('p_nudging_u',p_nudging_u)
     556       CALL getin('p_nudging_v',p_nudging_v)
     557       CALL getin('p_nudging_t',p_nudging_t)
     558       CALL getin('p_nudging_qv',p_nudging_qv)
    548559
    549560!Config  Key  = nudging_t
    … …  
    599610      write(lunout,*)' nudging_v  = ', nudging_v
    600611      write(lunout,*)' nudging_t  = ', nudging_t
    601       write(lunout,*)' nudging_q  = ', nudging_q
     612      write(lunout,*)' nudging_qv  = ', nudging_qv
    602613      IF (forcing_type .eq.40) THEN
    603614        write(lunout,*) '--- Forcing type GCSS Old --- with:'
    … …  
    814825      character*80 abort_message
    815826!
    816       INTEGER nb
    817       SAVE nb
    818       DATA nb / 0 /
     827      INTEGER pass
    819828
    820829      CALL open_restartphy(fichnom)
    … …  
    828837      ENDDO
    829838
    830       modname = 'dyn1dredem'
    831       ierr = NF_OPEN(fichnom, NF_WRITE, nid)
    832       IF (ierr .NE. NF_NOERR) THEN
    833          abort_message="Pb. d ouverture "//fichnom
    834          CALL abort_gcm('Modele 1D',abort_message,1)
    835       ENDIF
     839!     modname = 'dyn1dredem'
     840!     ierr = NF_OPEN(fichnom, NF_WRITE, nid)
     841!     IF (ierr .NE. NF_NOERR) THEN
     842!        abort_message="Pb. d ouverture "//fichnom
     843!        CALL abort_gcm('Modele 1D',abort_message,1)
     844!     ENDIF
    836845
    837846      DO l=1,length
    … …  
    885894       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
    886895!
    887       CALL put_var("controle","Param. de controle Dyn1D",tab_cntrl)
     896      DO pass=1,2
     897      CALL put_var(pass,"controle","Param. de controle Dyn1D",tab_cntrl)
    888898!
    889899
    890900!  Ecriture/extension de la coordonnee temps
    891901
    892       nb = nb + 1
    893902
    894903!  Ecriture des champs
    895904!
    896       CALL put_field("plev","p interfaces sauf la nulle",plev)
    897       CALL put_field("play","",play)
    898       CALL put_field("phi","geopotentielle",phi)
    899       CALL put_field("phis","geopotentiell de surface",phis)
    900       CALL put_field("presnivs","",presnivs)
    901       CALL put_field("ucov","",ucov)
    902       CALL put_field("vcov","",vcov)
    903       CALL put_field("temp","",temp)
    904       CALL put_field("omega2","",omega2)
     905      CALL put_field(pass,"plev","p interfaces sauf la nulle",plev)
     906      CALL put_field(pass,"play","",play)
     907      CALL put_field(pass,"phi","geopotentielle",phi)
     908      CALL put_field(pass,"phis","geopotentiell de surface",phis)
     909      CALL put_field(pass,"presnivs","",presnivs)
     910      CALL put_field(pass,"ucov","",ucov)
     911      CALL put_field(pass,"vcov","",vcov)
     912      CALL put_field(pass,"temp","",temp)
     913      CALL put_field(pass,"omega2","",omega2)
    905914
    906915      Do iq=1,nqtot
    907         CALL put_field("q"//nmq(iq),"eau vap ou condens et traceurs",           &
     916        CALL put_field(pass,"q"//nmq(iq),"eau vap ou condens et traceurs",           &
    908917     &                                                      q(:,:,iq))
    909918      EndDo
    910       CALL close_restartphy
     919    IF (pass==1) CALL enddef_restartphy
     920    IF (pass==2) CALL close_restartphy
     921
     922
     923      ENDDO
    911924
    912925!
    … …  
    14581471
    14591472!======================================================================
    1460       SUBROUTINE read_togacoare(fich_toga,nlev_toga,nt_toga                     &
    1461      &             ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga        &
    1462      &             ,ht_toga,vt_toga,hq_toga,vq_toga)
    1463       implicit none
    1464 
    1465 !-------------------------------------------------------------------------
    1466 ! Read TOGA-COARE forcing data
    1467 !-------------------------------------------------------------------------
    1468 
    1469       integer nlev_toga,nt_toga
    1470       real ts_toga(nt_toga),plev_toga(nlev_toga,nt_toga)
    1471       real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)
    1472       real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)
    1473       real w_toga(nlev_toga,nt_toga)
    1474       real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
    1475       real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
    1476       character*80 fich_toga
    1477 
    1478       integer k,ip
    1479       real bid
    1480 
    1481       integer iy,im,id,ih
    1482      
    1483        real plev_min
    1484 
    1485        plev_min = 55.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
    1486 
    1487       open(21,file=trim(fich_toga),form='formatted')
    1488       read(21,'(a)')
    1489       do ip = 1, nt_toga
    1490       read(21,'(a)')
    1491       read(21,'(a)')
    1492       read(21,223) iy, im, id, ih, bid, ts_toga(ip), bid,bid,bid,bid
    1493       read(21,'(a)')
    1494       read(21,'(a)')
    1495 
    1496        do k = 1, nlev_toga
    1497          read(21,230) plev_toga(k,ip), t_toga(k,ip), q_toga(k,ip)          &
    1498      &       ,u_toga(k,ip), v_toga(k,ip), w_toga(k,ip)                     &
    1499      &       ,ht_toga(k,ip), vt_toga(k,ip), hq_toga(k,ip), vq_toga(k,ip)
    1500 
    1501 ! conversion in SI units:
    1502          t_toga(k,ip)=t_toga(k,ip)+273.15     ! K
    1503          q_toga(k,ip)=q_toga(k,ip)*0.001      ! kg/kg
    1504          w_toga(k,ip)=w_toga(k,ip)*100./3600. ! Pa/s
    1505 ! no water vapour tendency above 55 hPa
    1506          if (plev_toga(k,ip) .lt. plev_min) then
    1507           q_toga(k,ip) = 0.
    1508           hq_toga(k,ip) = 0.
    1509           vq_toga(k,ip) =0.
    1510          endif
    1511        enddo
    1512 
    1513          ts_toga(ip)=ts_toga(ip)+273.15       ! K
    1514        enddo
    1515        close(21)
    1516 
    1517   223 format(4i3,6f8.2)
    1518   230 format(6f9.3,4e11.3)
    1519 
    1520           return
    1521           end
    1522 
    1523 !-------------------------------------------------------------------------
    1524       SUBROUTINE read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)
    1525       implicit none
    1526 
    1527 !-------------------------------------------------------------------------
    1528 ! Read I.SANDU case forcing data
    1529 !-------------------------------------------------------------------------
    1530 
    1531       integer nlev_sandu,nt_sandu
    1532       real ts_sandu(nt_sandu)
    1533       character*80 fich_sandu
    1534 
    1535       integer ip
    1536       integer iy,im,id,ih
    1537 
    1538       real plev_min
    1539 
    1540       print*,'nlev_sandu',nlev_sandu
    1541       plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
    1542 
    1543       open(21,file=trim(fich_sandu),form='formatted')
    1544       read(21,'(a)')
    1545       do ip = 1, nt_sandu
    1546       read(21,'(a)')
    1547       read(21,'(a)')
    1548       read(21,223) iy, im, id, ih, ts_sandu(ip)
    1549       print *,'ts=',iy,im,id,ih,ip,ts_sandu(ip)
    1550       enddo
    1551       close(21)
    1552 
    1553   223 format(4i3,f8.2)
    1554 
    1555           return
    1556           end
    1557 
    1558 !=====================================================================
    1559 !-------------------------------------------------------------------------
    1560       SUBROUTINE read_astex(fich_astex,nlev_astex,nt_astex,div_astex,      &
    1561      & ts_astex,ug_astex,vg_astex,ufa_astex,vfa_astex)
    1562       implicit none
    1563 
    1564 !-------------------------------------------------------------------------
    1565 ! Read Astex case forcing data
    1566 !-------------------------------------------------------------------------
    1567 
    1568       integer nlev_astex,nt_astex
    1569       real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)
    1570       real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
    1571       character*80 fich_astex
    1572 
    1573       integer ip
    1574       integer iy,im,id,ih
    1575 
    1576        real plev_min
    1577 
    1578       print*,'nlev_astex',nlev_astex
    1579        plev_min = 55000.  ! pas de tendance de vap. d eau au-dessus de 55 hPa
    1580 
    1581       open(21,file=trim(fich_astex),form='formatted')
    1582       read(21,'(a)')
    1583       read(21,'(a)')
    1584       do ip = 1, nt_astex
    1585       read(21,'(a)')
    1586       read(21,'(a)')
    1587       read(21,223) iy, im, id, ih, div_astex(ip),ts_astex(ip),             &
    1588      &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vfa_astex(ip)
    1589       ts_astex(ip)=ts_astex(ip)+273.15
    1590       print *,'ts=',iy,im,id,ih,ip,div_astex(ip),ts_astex(ip),             &
    1591      &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vg_astex(ip)
    1592       enddo
    1593       close(21)
    1594 
    1595   223 format(4i3,e13.2,f7.2,f7.3,f7.2,f7.3,f7.2)
    1596 
    1597           return
    1598           end
    1599 !=====================================================================
    1600       subroutine read_twpice(fich_twpice,nlevel,ntime                       &
    1601      &     ,T_srf,plev,T,q,u,v,omega                                       &
    1602      &     ,T_adv_h,T_adv_v,q_adv_h,q_adv_v)
    1603 
    1604 !program reading forcings of the TWP-ICE experiment
    1605 
    1606 !      use netcdf
    1607 
    1608       implicit none
    1609 
    1610 #include "netcdf.inc"
    1611 
    1612       integer ntime,nlevel
    1613       integer l,k
    1614       character*80 :: fich_twpice
    1615       real*8 time(ntime)
    1616       real*8 lat, lon, alt, phis
    1617       real*8 lev(nlevel)
    1618       real*8 plev(nlevel,ntime)
    1619 
    1620       real*8 T(nlevel,ntime)
    1621       real*8 q(nlevel,ntime),u(nlevel,ntime)
    1622       real*8 v(nlevel,ntime)
    1623       real*8 omega(nlevel,ntime), div(nlevel,ntime)
    1624       real*8 T_adv_h(nlevel,ntime)
    1625       real*8 T_adv_v(nlevel,ntime), q_adv_h(nlevel,ntime)
    1626       real*8 q_adv_v(nlevel,ntime)
    1627       real*8 s(nlevel,ntime), s_adv_h(nlevel,ntime)
    1628       real*8 s_adv_v(nlevel,ntime)
    1629       real*8 p_srf_aver(ntime), p_srf_center(ntime)
    1630       real*8 T_srf(ntime)
    1631 
    1632       integer nid, ierr
    1633       integer nbvar3d
    1634       parameter(nbvar3d=20)
    1635       integer var3didin(nbvar3d)
    1636 
    1637       ierr = NF_OPEN(fich_twpice,NF_NOWRITE,nid)
    1638       if (ierr.NE.NF_NOERR) then
    1639          write(*,*) 'ERROR: Pb opening forcings cdf file '
    1640          write(*,*) NF_STRERROR(ierr)
    1641          stop ""
    1642       endif
    1643 
    1644       ierr=NF_INQ_VARID(nid,"lat",var3didin(1))
    1645          if(ierr/=NF_NOERR) then
    1646            write(*,*) NF_STRERROR(ierr)
    1647            stop 'lat'
    1648          endif
    1649      
    1650        ierr=NF_INQ_VARID(nid,"lon",var3didin(2))
    1651          if(ierr/=NF_NOERR) then
    1652            write(*,*) NF_STRERROR(ierr)
    1653            stop 'lon'
    1654          endif
    1655 
    1656        ierr=NF_INQ_VARID(nid,"alt",var3didin(3))
    1657          if(ierr/=NF_NOERR) then
    1658            write(*,*) NF_STRERROR(ierr)
    1659            stop 'alt'
    1660          endif
    1661 
    1662       ierr=NF_INQ_VARID(nid,"phis",var3didin(4))
    1663          if(ierr/=NF_NOERR) then
    1664            write(*,*) NF_STRERROR(ierr)
    1665            stop 'phis'
    1666          endif
    1667 
    1668       ierr=NF_INQ_VARID(nid,"T",var3didin(5))
    1669          if(ierr/=NF_NOERR) then
    1670            write(*,*) NF_STRERROR(ierr)
    1671            stop 'T'
    1672          endif
    1673 
    1674       ierr=NF_INQ_VARID(nid,"q",var3didin(6))
    1675          if(ierr/=NF_NOERR) then
    1676            write(*,*) NF_STRERROR(ierr)
    1677            stop 'q'
    1678          endif
    1679 
    1680       ierr=NF_INQ_VARID(nid,"u",var3didin(7))
    1681          if(ierr/=NF_NOERR) then
    1682            write(*,*) NF_STRERROR(ierr)
    1683            stop 'u'
    1684          endif
    1685 
    1686       ierr=NF_INQ_VARID(nid,"v",var3didin(8))
    1687          if(ierr/=NF_NOERR) then
    1688            write(*,*) NF_STRERROR(ierr)
    1689            stop 'v'
    1690          endif
    1691 
    1692       ierr=NF_INQ_VARID(nid,"omega",var3didin(9))
    1693          if(ierr/=NF_NOERR) then
    1694            write(*,*) NF_STRERROR(ierr)
    1695            stop 'omega'
    1696          endif
    1697 
    1698       ierr=NF_INQ_VARID(nid,"div",var3didin(10))
    1699          if(ierr/=NF_NOERR) then
    1700            write(*,*) NF_STRERROR(ierr)
    1701            stop 'div'
    1702          endif
    1703 
    1704       ierr=NF_INQ_VARID(nid,"T_adv_h",var3didin(11))
    1705          if(ierr/=NF_NOERR) then
    1706            write(*,*) NF_STRERROR(ierr)
    1707            stop 'T_adv_h'
    1708          endif
    1709 
    1710       ierr=NF_INQ_VARID(nid,"T_adv_v",var3didin(12))
    1711          if(ierr/=NF_NOERR) then
    1712            write(*,*) NF_STRERROR(ierr)
    1713            stop 'T_adv_v'
    1714          endif
    1715 
    1716       ierr=NF_INQ_VARID(nid,"q_adv_h",var3didin(13))
    1717          if(ierr/=NF_NOERR) then
    1718            write(*,*) NF_STRERROR(ierr)
    1719            stop 'q_adv_h'
    1720          endif
    1721 
    1722       ierr=NF_INQ_VARID(nid,"q_adv_v",var3didin(14))
    1723          if(ierr/=NF_NOERR) then
    1724            write(*,*) NF_STRERROR(ierr)
    1725            stop 'q_adv_v'
    1726          endif
    1727 
    1728       ierr=NF_INQ_VARID(nid,"s",var3didin(15))
    1729          if(ierr/=NF_NOERR) then
    1730            write(*,*) NF_STRERROR(ierr)
    1731            stop 's'
    1732          endif
    1733 
    1734       ierr=NF_INQ_VARID(nid,"s_adv_h",var3didin(16))
    1735          if(ierr/=NF_NOERR) then
    1736            write(*,*) NF_STRERROR(ierr)
    1737            stop 's_adv_h'
    1738          endif
    1739    
    1740       ierr=NF_INQ_VARID(nid,"s_adv_v",var3didin(17))
    1741          if(ierr/=NF_NOERR) then
    1742            write(*,*) NF_STRERROR(ierr)
    1743            stop 's_adv_v'
    1744          endif
    1745 
    1746       ierr=NF_INQ_VARID(nid,"p_srf_aver",var3didin(18))
    1747          if(ierr/=NF_NOERR) then
    1748            write(*,*) NF_STRERROR(ierr)
    1749            stop 'p_srf_aver'
    1750          endif
    1751 
    1752       ierr=NF_INQ_VARID(nid,"p_srf_center",var3didin(19))
    1753          if(ierr/=NF_NOERR) then
    1754            write(*,*) NF_STRERROR(ierr)
    1755            stop 'p_srf_center'
    1756          endif
    1757 
    1758       ierr=NF_INQ_VARID(nid,"T_srf",var3didin(20))
    1759          if(ierr/=NF_NOERR) then
    1760            write(*,*) NF_STRERROR(ierr)
    1761            stop 'T_srf'
    1762          endif
    1763 
    1764 !dimensions lecture
    1765       call catchaxis(nid,ntime,nlevel,time,lev,ierr)
    1766 
    1767 !pressure
    1768        do l=1,ntime
    1769        do k=1,nlevel
    1770           plev(k,l)=lev(k)
    1771        enddo
    1772        enddo
    1773          
    1774 #ifdef NC_DOUBLE
    1775          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),lat)
    1776 #else
    1777          ierr = NF_GET_VAR_REAL(nid,var3didin(1),lat)
    1778 #endif
    1779          if(ierr/=NF_NOERR) then
    1780             write(*,*) NF_STRERROR(ierr)
    1781             stop "getvarup"
    1782          endif
    1783 !         write(*,*)'lecture lat ok',lat
    1784 
    1785 #ifdef NC_DOUBLE
    1786          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),lon)
    1787 #else
    1788          ierr = NF_GET_VAR_REAL(nid,var3didin(2),lon)
    1789 #endif
    1790          if(ierr/=NF_NOERR) then
    1791             write(*,*) NF_STRERROR(ierr)
    1792             stop "getvarup"
    1793          endif
    1794 !         write(*,*)'lecture lon ok',lon
    1795  
    1796 #ifdef NC_DOUBLE
    1797          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),alt)
    1798 #else
    1799          ierr = NF_GET_VAR_REAL(nid,var3didin(3),alt)
    1800 #endif
    1801          if(ierr/=NF_NOERR) then
    1802             write(*,*) NF_STRERROR(ierr)
    1803             stop "getvarup"
    1804          endif
    1805 !          write(*,*)'lecture alt ok',alt
    1806  
    1807 #ifdef NC_DOUBLE
    1808          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),phis)
    1809 #else
    1810          ierr = NF_GET_VAR_REAL(nid,var3didin(4),phis)
    1811 #endif
    1812          if(ierr/=NF_NOERR) then
    1813             write(*,*) NF_STRERROR(ierr)
    1814             stop "getvarup"
    1815          endif
    1816 !          write(*,*)'lecture phis ok',phis
    1817          
    1818 #ifdef NC_DOUBLE
    1819          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),T)
    1820 #else
    1821          ierr = NF_GET_VAR_REAL(nid,var3didin(5),T)
    1822 #endif
    1823          if(ierr/=NF_NOERR) then
    1824             write(*,*) NF_STRERROR(ierr)
    1825             stop "getvarup"
    1826          endif
    1827 !         write(*,*)'lecture T ok'
    1828 
    1829 #ifdef NC_DOUBLE
    1830          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),q)
    1831 #else
    1832          ierr = NF_GET_VAR_REAL(nid,var3didin(6),q)
    1833 #endif
    1834          if(ierr/=NF_NOERR) then
    1835             write(*,*) NF_STRERROR(ierr)
    1836             stop "getvarup"
    1837          endif
    1838 !         write(*,*)'lecture q ok'
    1839 !q in kg/kg
    1840        do l=1,ntime
    1841        do k=1,nlevel
    1842           q(k,l)=q(k,l)/1000.
    1843        enddo
    1844        enddo
    1845 #ifdef NC_DOUBLE
    1846          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),u)
    1847 #else
    1848          ierr = NF_GET_VAR_REAL(nid,var3didin(7),u)
    1849 #endif
    1850          if(ierr/=NF_NOERR) then
    1851             write(*,*) NF_STRERROR(ierr)
    1852             stop "getvarup"
    1853          endif
    1854 !         write(*,*)'lecture u ok'
    1855 
    1856 #ifdef NC_DOUBLE
    1857          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),v)
    1858 #else
    1859          ierr = NF_GET_VAR_REAL(nid,var3didin(8),v)
    1860 #endif
    1861          if(ierr/=NF_NOERR) then
    1862             write(*,*) NF_STRERROR(ierr)
    1863             stop "getvarup"
    1864          endif
    1865 !         write(*,*)'lecture v ok'
    1866 
    1867 #ifdef NC_DOUBLE
    1868          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),omega)
    1869 #else
    1870          ierr = NF_GET_VAR_REAL(nid,var3didin(9),omega)
    1871 #endif
    1872          if(ierr/=NF_NOERR) then
    1873             write(*,*) NF_STRERROR(ierr)
    1874             stop "getvarup"
    1875          endif
    1876 !         write(*,*)'lecture omega ok'
    1877 !omega in mb/hour
    1878        do l=1,ntime
    1879        do k=1,nlevel
    1880           omega(k,l)=omega(k,l)*100./3600.
    1881        enddo
    1882        enddo
    1883 
    1884 #ifdef NC_DOUBLE
    1885          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),div)
    1886 #else
    1887          ierr = NF_GET_VAR_REAL(nid,var3didin(10),div)
    1888 #endif
    1889          if(ierr/=NF_NOERR) then
    1890             write(*,*) NF_STRERROR(ierr)
    1891             stop "getvarup"
    1892          endif
    1893 !         write(*,*)'lecture div ok'
    1894 
    1895 #ifdef NC_DOUBLE
    1896          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),T_adv_h)
    1897 #else
    1898          ierr = NF_GET_VAR_REAL(nid,var3didin(11),T_adv_h)
    1899 #endif
    1900          if(ierr/=NF_NOERR) then
    1901             write(*,*) NF_STRERROR(ierr)
    1902             stop "getvarup"
    1903          endif
    1904 !         write(*,*)'lecture T_adv_h ok'
    1905 !T adv in K/s
    1906        do l=1,ntime
    1907        do k=1,nlevel
    1908           T_adv_h(k,l)=T_adv_h(k,l)/3600.
    1909        enddo
    1910        enddo
    1911 
    1912 
    1913 #ifdef NC_DOUBLE
    1914          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),T_adv_v)
    1915 #else
    1916          ierr = NF_GET_VAR_REAL(nid,var3didin(12),T_adv_v)
    1917 #endif
    1918          if(ierr/=NF_NOERR) then
    1919             write(*,*) NF_STRERROR(ierr)
    1920             stop "getvarup"
    1921          endif
    1922 !         write(*,*)'lecture T_adv_v ok'
    1923 !T adv in K/s
    1924        do l=1,ntime
    1925        do k=1,nlevel
    1926           T_adv_v(k,l)=T_adv_v(k,l)/3600.
    1927        enddo
    1928        enddo
    1929 
    1930 #ifdef NC_DOUBLE
    1931          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),q_adv_h)
    1932 #else
    1933          ierr = NF_GET_VAR_REAL(nid,var3didin(13),q_adv_h)
    1934 #endif
    1935          if(ierr/=NF_NOERR) then
    1936             write(*,*) NF_STRERROR(ierr)
    1937             stop "getvarup"
    1938          endif
    1939 !         write(*,*)'lecture q_adv_h ok'
    1940 !q adv in kg/kg/s
    1941        do l=1,ntime
    1942        do k=1,nlevel
    1943           q_adv_h(k,l)=q_adv_h(k,l)/1000./3600.
    1944        enddo
    1945        enddo
    1946 
    1947 
    1948 #ifdef NC_DOUBLE
    1949          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),q_adv_v)
    1950 #else
    1951          ierr = NF_GET_VAR_REAL(nid,var3didin(14),q_adv_v)
    1952 #endif
    1953          if(ierr/=NF_NOERR) then
    1954             write(*,*) NF_STRERROR(ierr)
    1955             stop "getvarup"
    1956          endif
    1957 !         write(*,*)'lecture q_adv_v ok'
    1958 !q adv in kg/kg/s
    1959        do l=1,ntime
    1960        do k=1,nlevel
    1961           q_adv_v(k,l)=q_adv_v(k,l)/1000./3600.
    1962        enddo
    1963        enddo
    1964 
    1965 
    1966 #ifdef NC_DOUBLE
    1967          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),s)
    1968 #else
    1969          ierr = NF_GET_VAR_REAL(nid,var3didin(15),s)
    1970 #endif
    1971          if(ierr/=NF_NOERR) then
    1972             write(*,*) NF_STRERROR(ierr)
    1973             stop "getvarup"
    1974          endif
    1975 
    1976 #ifdef NC_DOUBLE
    1977          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),s_adv_h)
    1978 #else
    1979          ierr = NF_GET_VAR_REAL(nid,var3didin(16),s_adv_h)
    1980 #endif
    1981          if(ierr/=NF_NOERR) then
    1982             write(*,*) NF_STRERROR(ierr)
    1983             stop "getvarup"
    1984          endif
    1985 
    1986 #ifdef NC_DOUBLE
    1987          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),s_adv_v)
    1988 #else
    1989          ierr = NF_GET_VAR_REAL(nid,var3didin(17),s_adv_v)
    1990 #endif
    1991          if(ierr/=NF_NOERR) then
    1992             write(*,*) NF_STRERROR(ierr)
    1993             stop "getvarup"
    1994          endif
    1995 
    1996 #ifdef NC_DOUBLE
    1997          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),p_srf_aver)
    1998 #else
    1999          ierr = NF_GET_VAR_REAL(nid,var3didin(18),p_srf_aver)
    2000 #endif
    2001          if(ierr/=NF_NOERR) then
    2002             write(*,*) NF_STRERROR(ierr)
    2003             stop "getvarup"
    2004          endif
    2005 
    2006 #ifdef NC_DOUBLE
    2007          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),p_srf_center)
    2008 #else
    2009          ierr = NF_GET_VAR_REAL(nid,var3didin(19),p_srf_center)
    2010 #endif
    2011          if(ierr/=NF_NOERR) then
    2012             write(*,*) NF_STRERROR(ierr)
    2013             stop "getvarup"
    2014          endif
    2015 
    2016 #ifdef NC_DOUBLE
    2017          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),T_srf)
    2018 #else
    2019          ierr = NF_GET_VAR_REAL(nid,var3didin(20),T_srf)
    2020 #endif
    2021          if(ierr/=NF_NOERR) then
    2022             write(*,*) NF_STRERROR(ierr)
    2023             stop "getvarup"
    2024          endif
    2025 !         write(*,*)'lecture T_srf ok', T_srf
    2026 
    2027          return
    2028          end subroutine read_twpice
    2029 !=====================================================================
    2030          subroutine catchaxis(nid,ttm,llm,time,lev,ierr)
    2031 
    2032 !         use netcdf
    2033 
    2034          implicit none
    2035 #include "netcdf.inc"
    2036          integer nid,ttm,llm
    2037          real*8 time(ttm)
    2038          real*8 lev(llm)
    2039          integer ierr
    2040 
    2041          integer timevar,levvar
    2042          integer timelen,levlen
    2043          integer timedimin,levdimin
    2044 
    2045 ! Control & lecture on dimensions
    2046 ! ===============================
    2047          ierr=NF_INQ_DIMID(nid,"time",timedimin)
    2048          ierr=NF_INQ_VARID(nid,"time",timevar)
    2049          if (ierr.NE.NF_NOERR) then
    2050             write(*,*) 'ERROR: Field <time> is missing'
    2051             stop "" 
    2052          endif
    2053          ierr=NF_INQ_DIMLEN(nid,timedimin,timelen)
    2054 
    2055          ierr=NF_INQ_DIMID(nid,"lev",levdimin)
    2056          ierr=NF_INQ_VARID(nid,"lev",levvar)
    2057          if (ierr.NE.NF_NOERR) then
    2058              write(*,*) 'ERROR: Field <lev> is lacking'
    2059              stop ""
    2060          endif
    2061          ierr=NF_INQ_DIMLEN(nid,levdimin,levlen)
    2062 
    2063          if((timelen/=ttm).or.(levlen/=llm)) then
    2064             write(*,*) 'ERROR: Not the good lenght for axis'
    2065             write(*,*) 'longitude: ',timelen,ttm+1
    2066             write(*,*) 'latitude: ',levlen,llm
    2067             stop "" 
    2068          endif
    2069 
    2070 !#ifdef NC_DOUBLE
    2071          ierr = NF_GET_VAR_DOUBLE(nid,timevar,time)
    2072          ierr = NF_GET_VAR_DOUBLE(nid,levvar,lev)
    2073 !#else
    2074 !        ierr = NF_GET_VAR_REAL(nid,timevar,time)
    2075 !        ierr = NF_GET_VAR_REAL(nid,levvar,lev)
    2076 !#endif
    2077 
    2078        return
    2079        end
    2080 !=====================================================================
    2081 
    2082        SUBROUTINE interp_sandu_vertical(play,nlev_sandu,plev_prof          &
    2083      &         ,t_prof,thl_prof,q_prof,u_prof,v_prof,w_prof                &
    2084      &         ,omega_prof,o3mmr_prof                                      &
    2085      &         ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod                      &
    2086      &         ,omega_mod,o3mmr_mod,mxcalc)
    2087 
    2088        implicit none
    2089 
    2090 #include "dimensions.h"
    2091 
    2092 !-------------------------------------------------------------------------
    2093 ! Vertical interpolation of SANDUREF forcing data onto model levels
    2094 !-------------------------------------------------------------------------
    2095 
    2096        integer nlevmax
    2097        parameter (nlevmax=41)
    2098        integer nlev_sandu,mxcalc
    2099 !       real play(llm), plev_prof(nlevmax)
    2100 !       real t_prof(nlevmax),q_prof(nlevmax)
    2101 !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
    2102 !       real ht_prof(nlevmax),vt_prof(nlevmax)
    2103 !       real hq_prof(nlevmax),vq_prof(nlevmax)
    2104 
    2105        real play(llm), plev_prof(nlev_sandu)
    2106        real t_prof(nlev_sandu),thl_prof(nlev_sandu),q_prof(nlev_sandu)
    2107        real u_prof(nlev_sandu),v_prof(nlev_sandu), w_prof(nlev_sandu)
    2108        real omega_prof(nlev_sandu),o3mmr_prof(nlev_sandu)
    2109 
    2110        real t_mod(llm),thl_mod(llm),q_mod(llm)
    2111        real u_mod(llm),v_mod(llm), w_mod(llm)
    2112        real omega_mod(llm),o3mmr_mod(llm)
    2113 
    2114        integer l,k,k1,k2
    2115        real frac,frac1,frac2,fact
    2116 
    2117        do l = 1, llm
    2118 
    2119         if (play(l).ge.plev_prof(nlev_sandu)) then
    2120 
    2121         mxcalc=l
    2122          k1=0
    2123          k2=0
    2124 
    2125          if (play(l).le.plev_prof(1)) then
    2126 
    2127          do k = 1, nlev_sandu-1
    2128           if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then
    2129             k1=k
    2130             k2=k+1
    2131           endif
    2132          enddo
    2133 
    2134          if (k1.eq.0 .or. k2.eq.0) then
    2135           write(*,*) 'PB! k1, k2 = ',k1,k2
    2136           write(*,*) 'l,play(l) = ',l,play(l)/100
    2137          do k = 1, nlev_sandu-1
    2138           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2139          enddo
    2140          endif
    2141 
    2142          frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
    2143          t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
    2144          thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))
    2145          q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))
    2146          u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
    2147          v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
    2148          w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
    2149          omega_mod(l)=omega_prof(k2)-frac*(omega_prof(k2)-omega_prof(k1))
    2150          o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))
    2151 
    2152          else !play>plev_prof(1)
    2153 
    2154          k1=1
    2155          k2=2
    2156          frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
    2157          frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
    2158          t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
    2159          thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)
    2160          q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)
    2161          u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
    2162          v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
    2163          w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
    2164          omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)
    2165          o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)
    2166 
    2167          endif ! play.le.plev_prof(1)
    2168 
    2169         else ! above max altitude of forcing file
    2170 
    2171 !jyg
    2172          fact=20.*(plev_prof(nlev_sandu)-play(l))/plev_prof(nlev_sandu) !jyg
    2173          fact = max(fact,0.)                                           !jyg
    2174          fact = exp(-fact)                                             !jyg
    2175          t_mod(l)= t_prof(nlev_sandu)                                   !jyg
    2176          thl_mod(l)= thl_prof(nlev_sandu)                                   !jyg
    2177          q_mod(l)= q_prof(nlev_sandu)*fact                              !jyg
    2178          u_mod(l)= u_prof(nlev_sandu)*fact                              !jyg
    2179          v_mod(l)= v_prof(nlev_sandu)*fact                              !jyg
    2180          w_mod(l)= w_prof(nlev_sandu)*fact                              !jyg
    2181          omega_mod(l)= omega_prof(nlev_sandu)*fact                      !jyg
    2182          o3mmr_mod(l)= o3mmr_prof(nlev_sandu)*fact                      !jyg
    2183 
    2184         endif ! play
    2185 
    2186        enddo ! l
    2187 
    2188        do l = 1,llm
    2189 !      print *,'t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l) ',
    2190 !    $        l,t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l)
    2191        enddo
    2192 
    2193           return
    2194           end
    2195 !=====================================================================
    2196        SUBROUTINE interp_astex_vertical(play,nlev_astex,plev_prof          &
    2197      &         ,t_prof,thl_prof,qv_prof,ql_prof,qt_prof,u_prof,v_prof      &
    2198      &         ,w_prof,tke_prof,o3mmr_prof                                 &
    2199      &         ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod       &
    2200      &         ,tke_mod,o3mmr_mod,mxcalc)
    2201 
    2202        implicit none
    2203 
    2204 #include "dimensions.h"
    2205 
    2206 !-------------------------------------------------------------------------
    2207 ! Vertical interpolation of Astex forcing data onto model levels
    2208 !-------------------------------------------------------------------------
    2209 
    2210        integer nlevmax
    2211        parameter (nlevmax=41)
    2212        integer nlev_astex,mxcalc
    2213 !       real play(llm), plev_prof(nlevmax)
    2214 !       real t_prof(nlevmax),qv_prof(nlevmax)
    2215 !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
    2216 !       real ht_prof(nlevmax),vt_prof(nlevmax)
    2217 !       real hq_prof(nlevmax),vq_prof(nlevmax)
    2218 
    2219        real play(llm), plev_prof(nlev_astex)
    2220        real t_prof(nlev_astex),thl_prof(nlev_astex),qv_prof(nlev_astex)
    2221        real u_prof(nlev_astex),v_prof(nlev_astex), w_prof(nlev_astex)
    2222        real o3mmr_prof(nlev_astex),ql_prof(nlev_astex)
    2223        real qt_prof(nlev_astex),tke_prof(nlev_astex)
    2224 
    2225        real t_mod(llm),thl_mod(llm),qv_mod(llm)
    2226        real u_mod(llm),v_mod(llm), w_mod(llm),tke_mod(llm)
    2227        real o3mmr_mod(llm),ql_mod(llm),qt_mod(llm)
    2228 
    2229        integer l,k,k1,k2
    2230        real frac,frac1,frac2,fact
    2231 
    2232        do l = 1, llm
    2233 
    2234         if (play(l).ge.plev_prof(nlev_astex)) then
    2235 
    2236         mxcalc=l
    2237          k1=0
    2238          k2=0
    2239 
    2240          if (play(l).le.plev_prof(1)) then
    2241 
    2242          do k = 1, nlev_astex-1
    2243           if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then
    2244             k1=k
    2245             k2=k+1
    2246           endif
    2247          enddo
    2248 
    2249          if (k1.eq.0 .or. k2.eq.0) then
    2250           write(*,*) 'PB! k1, k2 = ',k1,k2
    2251           write(*,*) 'l,play(l) = ',l,play(l)/100
    2252          do k = 1, nlev_astex-1
    2253           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2254          enddo
    2255          endif
    2256 
    2257          frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
    2258          t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
    2259          thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))
    2260          qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))
    2261          ql_mod(l)= ql_prof(k2) - frac*(ql_prof(k2)-ql_prof(k1))
    2262          qt_mod(l)= qt_prof(k2) - frac*(qt_prof(k2)-qt_prof(k1))
    2263          u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
    2264          v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
    2265          w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
    2266          tke_mod(l)= tke_prof(k2) - frac*(tke_prof(k2)-tke_prof(k1))
    2267          o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))
    2268 
    2269          else !play>plev_prof(1)
    2270 
    2271          k1=1
    2272          k2=2
    2273          frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
    2274          frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
    2275          t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
    2276          thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)
    2277          qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)
    2278          ql_mod(l)= frac1*ql_prof(k1) - frac2*ql_prof(k2)
    2279          qt_mod(l)= frac1*qt_prof(k1) - frac2*qt_prof(k2)
    2280          u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
    2281          v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
    2282          w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
    2283          tke_mod(l)= frac1*tke_prof(k1) - frac2*tke_prof(k2)
    2284          o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)
    2285 
    2286          endif ! play.le.plev_prof(1)
    2287 
    2288         else ! above max altitude of forcing file
    2289 
    2290 !jyg
    2291          fact=20.*(plev_prof(nlev_astex)-play(l))/plev_prof(nlev_astex) !jyg
    2292          fact = max(fact,0.)                                           !jyg
    2293          fact = exp(-fact)                                             !jyg
    2294          t_mod(l)= t_prof(nlev_astex)                                   !jyg
    2295          thl_mod(l)= thl_prof(nlev_astex)                                   !jyg
    2296          qv_mod(l)= qv_prof(nlev_astex)*fact                              !jyg
    2297          ql_mod(l)= ql_prof(nlev_astex)*fact                              !jyg
    2298          qt_mod(l)= qt_prof(nlev_astex)*fact                              !jyg
    2299          u_mod(l)= u_prof(nlev_astex)*fact                              !jyg
    2300          v_mod(l)= v_prof(nlev_astex)*fact                              !jyg
    2301          w_mod(l)= w_prof(nlev_astex)*fact                              !jyg
    2302          tke_mod(l)= tke_prof(nlev_astex)*fact                              !jyg
    2303          o3mmr_mod(l)= o3mmr_prof(nlev_astex)*fact                      !jyg
    2304 
    2305         endif ! play
    2306 
    2307        enddo ! l
    2308 
    2309        do l = 1,llm
    2310 !      print *,'t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l) ',
    2311 !    $        l,t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l)
    2312        enddo
    2313 
    2314           return
    2315           end
    2316 
    2317 !======================================================================
    2318       SUBROUTINE read_rico(fich_rico,nlev_rico,ps_rico,play                &
    2319      &             ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico             &
    2320      &             ,dth_dyn,dqh_dyn)
    2321       implicit none
    2322 
    2323 !-------------------------------------------------------------------------
    2324 ! Read RICO forcing data
    2325 !-------------------------------------------------------------------------
    2326 #include "dimensions.h"
    2327 
    2328 
    2329       integer nlev_rico
    2330       real ts_rico,ps_rico
    2331       real t_rico(llm),q_rico(llm)
    2332       real u_rico(llm),v_rico(llm)
    2333       real w_rico(llm)
    2334       real dth_dyn(llm)
    2335       real dqh_dyn(llm)
    2336      
    2337 
    2338       real play(llm),zlay(llm)
    2339      
    2340 
    2341       real prico(nlev_rico),zrico(nlev_rico)
    2342 
    2343       character*80 fich_rico
    2344 
    2345       integer k,l
    2346 
    2347      
    2348       print*,fich_rico
    2349       open(21,file=trim(fich_rico),form='formatted')
    2350         do k=1,llm
    2351       zlay(k)=0.
    2352          enddo
    2353      
    2354         read(21,*) ps_rico,ts_rico
    2355         prico(1)=ps_rico
    2356         zrico(1)=0.0
    2357       do l=2,nlev_rico
    2358         read(21,*) k,prico(l),zrico(l)
    2359       enddo
    2360        close(21)
    2361 
    2362       do k=1,llm
    2363         do l=1,80
    2364           if(prico(l)>play(k)) then
    2365               if(play(k)>prico(l+1)) then
    2366                 zlay(k)=zrico(l)+(play(k)-prico(l)) *                      &
    2367      &              (zrico(l+1)-zrico(l))/(prico(l+1)-prico(l))
    2368               else
    2369                 zlay(k)=zrico(l)+(play(k)-prico(80))*                      &
    2370      &              (zrico(81)-zrico(80))/(prico(81)-prico(80))
    2371               endif
    2372           endif
    2373         enddo
    2374         print*,k,zlay(k)
    2375         ! U
    2376         if(0 < zlay(k) .and. zlay(k) < 4000) then
    2377           u_rico(k)=-9.9 + (-1.9 + 9.9)*zlay(k)/4000
    2378         elseif(4000 < zlay(k) .and. zlay(k) < 12000) then
    2379        u_rico(k)=  -1.9 + (30.0 + 1.9) /                                   &
    2380      &          (12000 - 4000) * (zlay(k) - 4000)
    2381         elseif(12000 < zlay(k) .and. zlay(k) < 13000) then
    2382           u_rico(k)=30.0
    2383         elseif(13000 < zlay(k) .and. zlay(k) < 20000) then
    2384           u_rico(k)=30.0 - (30.0) /                                        &
    2385      & (20000 - 13000) * (zlay(k) - 13000)
    2386         else
    2387           u_rico(k)=0.0
    2388         endif
    2389 
    2390 !Q_v
    2391         if(0 < zlay(k) .and. zlay(k) < 740) then
    2392           q_rico(k)=16.0 + (13.8 - 16.0) / (740) * zlay(k)
    2393         elseif(740 < zlay(k) .and. zlay(k) < 3260) then
    2394           q_rico(k)=13.8 + (2.4 - 13.8) /                                   &
    2395      &          (3260 - 740) * (zlay(k) - 740)
    2396         elseif(3260 < zlay(k) .and. zlay(k) < 4000) then
    2397           q_rico(k)=2.4 + (1.8 - 2.4) /                                    &
    2398      &               (4000 - 3260) * (zlay(k) - 3260)
    2399         elseif(4000 < zlay(k) .and. zlay(k) < 9000) then
    2400           q_rico(k)=1.8 + (0 - 1.8) /                                      &
    2401      &             (9000 - 4000) * (zlay(k) - 4000)
    2402         else
    2403           q_rico(k)=0.0
    2404         endif
    2405 
    2406 !T
    2407         if(0 < zlay(k) .and. zlay(k) < 740) then
    2408           t_rico(k)=299.2 + (292.0 - 299.2) / (740) * zlay(k)
    2409         elseif(740 < zlay(k) .and. zlay(k) < 4000) then
    2410           t_rico(k)=292.0 + (278.0 - 292.0) /                              &                       
    2411      &       (4000 - 740) * (zlay(k) - 740)
    2412         elseif(4000 < zlay(k) .and. zlay(k) < 15000) then
    2413           t_rico(k)=278.0 + (203.0 - 278.0) /                              &
    2414      &       (15000 - 4000) * (zlay(k) - 4000)
    2415         elseif(15000 < zlay(k) .and. zlay(k) < 17500) then
    2416           t_rico(k)=203.0 + (194.0 - 203.0) /                              &
    2417      &       (17500 - 15000)* (zlay(k) - 15000)
    2418         elseif(17500 < zlay(k) .and. zlay(k) < 20000) then
    2419           t_rico(k)=194.0 + (206.0 - 194.0) /                              &
    2420      &       (20000 - 17500)* (zlay(k) - 17500)
    2421         elseif(20000 < zlay(k) .and. zlay(k) < 60000) then
    2422           t_rico(k)=206.0 + (270.0 - 206.0) /                              &
    2423      &        (60000 - 20000)* (zlay(k) - 20000)
    2424         endif
    2425 
    2426 ! W
    2427         if(0 < zlay(k) .and. zlay(k) < 2260 ) then
    2428           w_rico(k)=- (0.005/2260) * zlay(k)
    2429         elseif(2260 < zlay(k) .and. zlay(k) < 4000 ) then
    2430           w_rico(k)=- 0.005
    2431         elseif(4000 < zlay(k) .and. zlay(k) < 5000 ) then
    2432        w_rico(k)=- 0.005 + (0.005/ (5000 - 4000)) * (zlay(k) - 4000)
    2433         else
    2434           w_rico(k)=0.0
    2435         endif
    2436 
    2437 ! dThrz+dTsw0+dTlw0
    2438         if(0 < zlay(k) .and. zlay(k) < 4000) then
    2439           dth_dyn(k)=- 2.51 / 86400 + (-2.18 + 2.51 )/                     &
    2440      &               (86400*4000) * zlay(k)
    2441         elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
    2442           dth_dyn(k)=- 2.18 / 86400 + ( 2.18 ) /                           &
    2443      &           (86400*(5000 - 4000)) * (zlay(k) - 4000)
    2444         else
    2445           dth_dyn(k)=0.0
    2446         endif
    2447 ! dQhrz
    2448         if(0 < zlay(k) .and. zlay(k) < 3000) then
    2449           dqh_dyn(k)=-1.0 / 86400 + (0.345 + 1.0)/                         &
    2450      &                    (86400*3000) * (zlay(k))
    2451         elseif(3000 < zlay(k) .and. zlay(k) < 4000) then
    2452           dqh_dyn(k)=0.345 / 86400
    2453         elseif(4000 < zlay(k) .and. zlay(k) < 5000) then
    2454           dqh_dyn(k)=0.345 / 86400 +                                       &
    2455      &   (-0.345)/(86400 * (5000 - 4000)) * (zlay(k)-4000)
    2456         else
    2457           dqh_dyn(k)=0.0
    2458         endif
    2459 
    2460 !?        if(play(k)>6e4) then
    2461 !?          ratqs0(1,k)=ratqsbas*(plev(1)-play(k))/(plev(1)-6e4)
    2462 !?        elseif((play(k)>3e4).and.(play(k)<6e4)) then
    2463 !?          ratqs0(1,k)=ratqsbas+(ratqshaut-ratqsbas)&
    2464 !?                          *(6e4-play(k))/(6e4-3e4)
    2465 !?        else
    2466 !?          ratqs0(1,k)=ratqshaut
    2467 !?        endif
    2468 
    2469       enddo
    2470 
    2471       do k=1,llm
    2472       q_rico(k)=q_rico(k)/1e3
    2473       dqh_dyn(k)=dqh_dyn(k)/1e3
    2474       v_rico(k)=-3.8
    2475       enddo
    2476 
    2477           return
    2478           end
    2479 
    2480 !======================================================================
    2481         SUBROUTINE interp_sandu_time(day,day1,annee_ref                    &
    2482      &             ,year_ini_sandu,day_ini_sandu,nt_sandu,dt_sandu         &
    2483      &             ,nlev_sandu,ts_sandu,ts_prof)
    2484         implicit none
    2485 
    2486 !---------------------------------------------------------------------------------------
    2487 ! Time interpolation of a 2D field to the timestep corresponding to day
    2488 !
    2489 ! day: current julian day (e.g. 717538.2)
    2490 ! day1: first day of the simulation
    2491 ! nt_sandu: total nb of data in the forcing (e.g. 13 for Sanduref)
    2492 ! dt_sandu: total time interval (in sec) between 2 forcing data (e.g. 6h for Sanduref)
    2493 !---------------------------------------------------------------------------------------
    2494 ! inputs:
    2495         integer annee_ref
    2496         integer nt_sandu,nlev_sandu
    2497         integer year_ini_sandu
    2498         real day, day1,day_ini_sandu,dt_sandu
    2499         real ts_sandu(nt_sandu)
    2500 ! outputs:
    2501         real ts_prof
    2502 ! local:
    2503         integer it_sandu1, it_sandu2
    2504         real timeit,time_sandu1,time_sandu2,frac
    2505 ! Check that initial day of the simulation consistent with SANDU period:
    2506        if (annee_ref.ne.2006 ) then
    2507         print*,'Pour SANDUREF, annee_ref doit etre 2006 '
    2508         print*,'Changer annee_ref dans run.def'
    2509         stop
    2510        endif
    2511 !      if (annee_ref.eq.2006 .and. day1.lt.day_ini_sandu) then
    2512 !       print*,'SANDUREF debute le 15 Juillet 2006 (jour julien=196)'
    2513 !       print*,'Changer dayref dans run.def'
    2514 !       stop
    2515 !      endif
    2516 
    2517 ! Determine timestep relative to the 1st day of TOGA-COARE:
    2518 !       timeit=(day-day1)*86400.
    2519 !       if (annee_ref.eq.1992) then
    2520 !        timeit=(day-day_ini_sandu)*86400.
    2521 !       else
    2522 !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
    2523 !       endif
    2524       timeit=(day-day_ini_sandu)*86400
    2525 
    2526 ! Determine the closest observation times:
    2527        it_sandu1=INT(timeit/dt_sandu)+1
    2528        it_sandu2=it_sandu1 + 1
    2529        time_sandu1=(it_sandu1-1)*dt_sandu
    2530        time_sandu2=(it_sandu2-1)*dt_sandu
    2531        print *,'timeit day day_ini_sandu',timeit,day,day_ini_sandu
    2532        print *,'it_sandu1,it_sandu2,time_sandu1,time_sandu2',              &
    2533      &          it_sandu1,it_sandu2,time_sandu1,time_sandu2
    2534 
    2535        if (it_sandu1 .ge. nt_sandu) then
    2536         write(*,*) 'PB-stop: day, it_sandu1, it_sandu2, timeit: '          &
    2537      &        ,day,it_sandu1,it_sandu2,timeit/86400.
    2538         stop
    2539        endif
    2540 
    2541 ! time interpolation:
    2542        frac=(time_sandu2-timeit)/(time_sandu2-time_sandu1)
    2543        frac=max(frac,0.0)
    2544 
    2545        ts_prof = ts_sandu(it_sandu2)                                       &
    2546      &          -frac*(ts_sandu(it_sandu2)-ts_sandu(it_sandu1))
    2547 
    2548          print*,                                                           &
    2549      &'day,annee_ref,day_ini_sandu,timeit,it_sandu1,it_sandu2,SST:',       &
    2550      &day,annee_ref,day_ini_sandu,timeit/86400.,it_sandu1,                  &
    2551      &it_sandu2,ts_prof
    2552 
    2553         return
    2554         END
    2555 !=====================================================================
    2556 !-------------------------------------------------------------------------
    2557       SUBROUTINE read_armcu(fich_armcu,nlev_armcu,nt_armcu,                &
    2558      & sens,flat,adv_theta,rad_theta,adv_qt)
    2559       implicit none
    2560 
    2561 !-------------------------------------------------------------------------
    2562 ! Read ARM_CU case forcing data
    2563 !-------------------------------------------------------------------------
    2564 
    2565       integer nlev_armcu,nt_armcu
    2566       real sens(nt_armcu),flat(nt_armcu)
    2567       real adv_theta(nt_armcu),rad_theta(nt_armcu),adv_qt(nt_armcu)
    2568       character*80 fich_armcu
    2569 
    2570       integer ip
    2571 
    2572       integer iy,im,id,ih,in
    2573 
    2574       print*,'nlev_armcu',nlev_armcu
    2575 
    2576       open(21,file=trim(fich_armcu),form='formatted')
    2577       read(21,'(a)')
    2578       do ip = 1, nt_armcu
    2579       read(21,'(a)')
    2580       read(21,'(a)')
    2581       read(21,223) iy, im, id, ih, in, sens(ip),flat(ip),                  &
    2582      &             adv_theta(ip),rad_theta(ip),adv_qt(ip)
    2583       print *,'forcages=',iy,im,id,ih,in, sens(ip),flat(ip),               &
    2584      &             adv_theta(ip),rad_theta(ip),adv_qt(ip)
    2585       enddo
    2586       close(21)
    2587 
    2588   223 format(5i3,5f8.3)
    2589 
    2590           return
    2591           end
    2592 
    2593 !=====================================================================
    2594        SUBROUTINE interp_toga_vertical(play,nlev_toga,plev_prof            &
    2595      &         ,t_prof,q_prof,u_prof,v_prof,w_prof                         &
    2596      &         ,ht_prof,vt_prof,hq_prof,vq_prof                            &
    2597      &         ,t_mod,q_mod,u_mod,v_mod,w_mod                              &
    2598      &         ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)
    2599  
    2600        implicit none
    2601  
    2602 #include "dimensions.h"
    2603 
    2604 !-------------------------------------------------------------------------
    2605 ! Vertical interpolation of TOGA-COARE forcing data onto model levels
    2606 !-------------------------------------------------------------------------
    2607  
    2608        integer nlevmax
    2609        parameter (nlevmax=41)
    2610        integer nlev_toga,mxcalc
    2611 !       real play(llm), plev_prof(nlevmax)
    2612 !       real t_prof(nlevmax),q_prof(nlevmax)
    2613 !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
    2614 !       real ht_prof(nlevmax),vt_prof(nlevmax)
    2615 !       real hq_prof(nlevmax),vq_prof(nlevmax)
    2616  
    2617        real play(llm), plev_prof(nlev_toga)
    2618        real t_prof(nlev_toga),q_prof(nlev_toga)
    2619        real u_prof(nlev_toga),v_prof(nlev_toga), w_prof(nlev_toga)
    2620        real ht_prof(nlev_toga),vt_prof(nlev_toga)
    2621        real hq_prof(nlev_toga),vq_prof(nlev_toga)
    2622  
    2623        real t_mod(llm),q_mod(llm)
    2624        real u_mod(llm),v_mod(llm), w_mod(llm)
    2625        real ht_mod(llm),vt_mod(llm)
    2626        real hq_mod(llm),vq_mod(llm)
    2627  
    2628        integer l,k,k1,k2
    2629        real frac,frac1,frac2,fact
    2630  
    2631        do l = 1, llm
    2632 
    2633         if (play(l).ge.plev_prof(nlev_toga)) then
    2634  
    2635         mxcalc=l
    2636          k1=0
    2637          k2=0
    2638 
    2639          if (play(l).le.plev_prof(1)) then
    2640 
    2641          do k = 1, nlev_toga-1
    2642           if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then
    2643             k1=k
    2644             k2=k+1
    2645           endif
    2646          enddo
    2647 
    2648          if (k1.eq.0 .or. k2.eq.0) then
    2649           write(*,*) 'PB! k1, k2 = ',k1,k2
    2650           write(*,*) 'l,play(l) = ',l,play(l)/100
    2651          do k = 1, nlev_toga-1
    2652           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2653          enddo
    2654          endif
    2655 
    2656          frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
    2657          t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))
    2658          q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))
    2659          u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
    2660          v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
    2661          w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
    2662          ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))
    2663          vt_mod(l)= vt_prof(k2) - frac*(vt_prof(k2)-vt_prof(k1))
    2664          hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))
    2665          vq_mod(l)= vq_prof(k2) - frac*(vq_prof(k2)-vq_prof(k1))
    2666      
    2667          else !play>plev_prof(1)
    2668 
    2669          k1=1
    2670          k2=2
    2671          frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
    2672          frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
    2673          t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)
    2674          q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)
    2675          u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
    2676          v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
    2677          w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
    2678          ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)
    2679          vt_mod(l)= frac1*vt_prof(k1) - frac2*vt_prof(k2)
    2680          hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)
    2681          vq_mod(l)= frac1*vq_prof(k1) - frac2*vq_prof(k2)
    2682 
    2683          endif ! play.le.plev_prof(1)
    2684 
    2685         else ! above max altitude of forcing file
    2686  
    2687 !jyg
    2688          fact=20.*(plev_prof(nlev_toga)-play(l))/plev_prof(nlev_toga) !jyg
    2689          fact = max(fact,0.)                                           !jyg
    2690          fact = exp(-fact)                                             !jyg
    2691          t_mod(l)= t_prof(nlev_toga)                                   !jyg
    2692          q_mod(l)= q_prof(nlev_toga)*fact                              !jyg
    2693          u_mod(l)= u_prof(nlev_toga)*fact                              !jyg
    2694          v_mod(l)= v_prof(nlev_toga)*fact                              !jyg
    2695          w_mod(l)= 0.0                                                 !jyg
    2696          ht_mod(l)= ht_prof(nlev_toga)                                 !jyg
    2697          vt_mod(l)= vt_prof(nlev_toga)                                 !jyg
    2698          hq_mod(l)= hq_prof(nlev_toga)*fact                            !jyg
    2699          vq_mod(l)= vq_prof(nlev_toga)*fact                            !jyg
    2700  
    2701         endif ! play
    2702  
    2703        enddo ! l
    2704 
    2705 !       do l = 1,llm
    2706 !       print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',
    2707 !     $        l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)
    2708 !       enddo
    2709  
    2710           return
    2711           end
    2712  
    2713 !=====================================================================
    2714        SUBROUTINE interp_case_vertical(play,nlev_cas,plev_prof_cas            &
    2715      &         ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas                         &
    2716      &         ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas           &
    2717      &         ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas                            &
    2718      &         ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas                              &
    2719      &         ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas               &
    2720      &         ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc)
    2721  
    2722        implicit none
    2723  
    2724 #include "dimensions.h"
    2725 
    2726 !-------------------------------------------------------------------------
    2727 ! Vertical interpolation of TOGA-COARE forcing data onto mod_casel levels
    2728 !-------------------------------------------------------------------------
    2729  
    2730        integer nlevmax
    2731        parameter (nlevmax=41)
    2732        integer nlev_cas,mxcalc
    2733 !       real play(llm), plev_prof(nlevmax)
    2734 !       real t_prof(nlevmax),q_prof(nlevmax)
    2735 !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
    2736 !       real ht_prof(nlevmax),vt_prof(nlevmax)
    2737 !       real hq_prof(nlevmax),vq_prof(nlevmax)
    2738  
    2739        real play(llm), plev_prof_cas(nlev_cas)
    2740        real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)
    2741        real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
    2742        real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas)
    2743        real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
    2744        real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
    2745        real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas),dtrad_prof_cas(nlev_cas)
    2746        real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
    2747  
    2748        real t_mod_cas(llm),q_mod_cas(llm)
    2749        real u_mod_cas(llm),v_mod_cas(llm)
    2750        real ug_mod_cas(llm),vg_mod_cas(llm), w_mod_cas(llm)
    2751        real du_mod_cas(llm),hu_mod_cas(llm),vu_mod_cas(llm)
    2752        real dv_mod_cas(llm),hv_mod_cas(llm),vv_mod_cas(llm)
    2753        real dt_mod_cas(llm),ht_mod_cas(llm),vt_mod_cas(llm),dtrad_mod_cas(llm)
    2754        real dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)
    2755  
    2756        integer l,k,k1,k2
    2757        real frac,frac1,frac2,fact
    2758  
    2759        do l = 1, llm
    2760 
    2761         if (play(l).ge.plev_prof_cas(nlev_cas)) then
    2762  
    2763         mxcalc=l
    2764          k1=0
    2765          k2=0
    2766 
    2767          if (play(l).le.plev_prof_cas(1)) then
    2768 
    2769          do k = 1, nlev_cas-1
    2770           if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then
    2771             k1=k
    2772             k2=k+1
    2773           endif
    2774          enddo
    2775 
    2776          if (k1.eq.0 .or. k2.eq.0) then
    2777           write(*,*) 'PB! k1, k2 = ',k1,k2
    2778           write(*,*) 'l,play(l) = ',l,play(l)/100
    2779          do k = 1, nlev_cas-1
    2780           write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100
    2781          enddo
    2782          endif
    2783 
    2784          frac = (plev_prof_cas(k2)-play(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))
    2785          t_mod_cas(l)= t_prof_cas(k2) - frac*(t_prof_cas(k2)-t_prof_cas(k1))
    2786          q_mod_cas(l)= q_prof_cas(k2) - frac*(q_prof_cas(k2)-q_prof_cas(k1))
    2787          u_mod_cas(l)= u_prof_cas(k2) - frac*(u_prof_cas(k2)-u_prof_cas(k1))
    2788          v_mod_cas(l)= v_prof_cas(k2) - frac*(v_prof_cas(k2)-v_prof_cas(k1))
    2789          ug_mod_cas(l)= ug_prof_cas(k2) - frac*(ug_prof_cas(k2)-ug_prof_cas(k1))
    2790          vg_mod_cas(l)= vg_prof_cas(k2) - frac*(vg_prof_cas(k2)-vg_prof_cas(k1))
    2791          w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_prof_cas(k1))
    2792          du_mod_cas(l)= du_prof_cas(k2) - frac*(du_prof_cas(k2)-du_prof_cas(k1))
    2793          hu_mod_cas(l)= hu_prof_cas(k2) - frac*(hu_prof_cas(k2)-hu_prof_cas(k1))
    2794          vu_mod_cas(l)= vu_prof_cas(k2) - frac*(vu_prof_cas(k2)-vu_prof_cas(k1))
    2795          dv_mod_cas(l)= dv_prof_cas(k2) - frac*(dv_prof_cas(k2)-dv_prof_cas(k1))
    2796          hv_mod_cas(l)= hv_prof_cas(k2) - frac*(hv_prof_cas(k2)-hv_prof_cas(k1))
    2797          vv_mod_cas(l)= vv_prof_cas(k2) - frac*(vv_prof_cas(k2)-vv_prof_cas(k1))
    2798          dt_mod_cas(l)= dt_prof_cas(k2) - frac*(dt_prof_cas(k2)-dt_prof_cas(k1))
    2799          ht_mod_cas(l)= ht_prof_cas(k2) - frac*(ht_prof_cas(k2)-ht_prof_cas(k1))
    2800          vt_mod_cas(l)= vt_prof_cas(k2) - frac*(vt_prof_cas(k2)-vt_prof_cas(k1))
    2801          dq_mod_cas(l)= dq_prof_cas(k2) - frac*(dq_prof_cas(k2)-dq_prof_cas(k1))
    2802          hq_mod_cas(l)= hq_prof_cas(k2) - frac*(hq_prof_cas(k2)-hq_prof_cas(k1))
    2803          vq_mod_cas(l)= vq_prof_cas(k2) - frac*(vq_prof_cas(k2)-vq_prof_cas(k1))
    2804          dtrad_mod_cas(l)= dtrad_prof_cas(k2) - frac*(dtrad_prof_cas(k2)-dtrad_prof_cas(k1))
    2805      
    2806          else !play>plev_prof_cas(1)
    2807 
    2808          k1=1
    2809          k2=2
    2810          frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))
    2811          frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))
    2812          t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)
    2813          q_mod_cas(l)= frac1*q_prof_cas(k1) - frac2*q_prof_cas(k2)
    2814          u_mod_cas(l)= frac1*u_prof_cas(k1) - frac2*u_prof_cas(k2)
    2815          v_mod_cas(l)= frac1*v_prof_cas(k1) - frac2*v_prof_cas(k2)
    2816          ug_mod_cas(l)= frac1*ug_prof_cas(k1) - frac2*ug_prof_cas(k2)
    2817          vg_mod_cas(l)= frac1*vg_prof_cas(k1) - frac2*vg_prof_cas(k2)
    2818          w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_prof_cas(k2)
    2819          du_mod_cas(l)= frac1*du_prof_cas(k1) - frac2*du_prof_cas(k2)
    2820          hu_mod_cas(l)= frac1*hu_prof_cas(k1) - frac2*hu_prof_cas(k2)
    2821          vu_mod_cas(l)= frac1*vu_prof_cas(k1) - frac2*vu_prof_cas(k2)
    2822          dv_mod_cas(l)= frac1*dv_prof_cas(k1) - frac2*dv_prof_cas(k2)
    2823          hv_mod_cas(l)= frac1*hv_prof_cas(k1) - frac2*hv_prof_cas(k2)
    2824          vv_mod_cas(l)= frac1*vv_prof_cas(k1) - frac2*vv_prof_cas(k2)
    2825          dt_mod_cas(l)= frac1*dt_prof_cas(k1) - frac2*dt_prof_cas(k2)
    2826          ht_mod_cas(l)= frac1*ht_prof_cas(k1) - frac2*ht_prof_cas(k2)
    2827          vt_mod_cas(l)= frac1*vt_prof_cas(k1) - frac2*vt_prof_cas(k2)
    2828          dq_mod_cas(l)= frac1*dq_prof_cas(k1) - frac2*dq_prof_cas(k2)
    2829          hq_mod_cas(l)= frac1*hq_prof_cas(k1) - frac2*hq_prof_cas(k2)
    2830          vq_mod_cas(l)= frac1*vq_prof_cas(k1) - frac2*vq_prof_cas(k2)
    2831          dtrad_mod_cas(l)= frac1*dtrad_prof_cas(k1) - frac2*dtrad_prof_cas(k2)
    2832 
    2833          endif ! play.le.plev_prof_cas(1)
    2834 
    2835         else ! above max altitude of forcing file
    2836  
    2837 !jyg
    2838          fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg
    2839          fact = max(fact,0.)                                           !jyg
    2840          fact = exp(-fact)                                             !jyg
    2841          t_mod_cas(l)= t_prof_cas(nlev_cas)                                   !jyg
    2842          q_mod_cas(l)= q_prof_cas(nlev_cas)*fact                              !jyg
    2843          u_mod_cas(l)= u_prof_cas(nlev_cas)*fact                              !jyg
    2844          v_mod_cas(l)= v_prof_cas(nlev_cas)*fact                              !jyg
    2845          ug_mod_cas(l)= ug_prof_cas(nlev_cas)*fact                              !jyg
    2846          vg_mod_cas(l)= vg_prof_cas(nlev_cas)*fact                              !jyg
    2847          w_mod_cas(l)= 0.0                                                 !jyg
    2848          du_mod_cas(l)= du_prof_cas(nlev_cas)*fact
    2849          hu_mod_cas(l)= hu_prof_cas(nlev_cas)*fact                            !jyg
    2850          vu_mod_cas(l)= vu_prof_cas(nlev_cas)*fact                            !jyg
    2851          dv_mod_cas(l)= dv_prof_cas(nlev_cas)*fact
    2852          hv_mod_cas(l)= hv_prof_cas(nlev_cas)*fact                            !jyg
    2853          vv_mod_cas(l)= vv_prof_cas(nlev_cas)*fact                            !jyg
    2854          dt_mod_cas(l)= dt_prof_cas(nlev_cas)
    2855          ht_mod_cas(l)= ht_prof_cas(nlev_cas)                                 !jyg
    2856          vt_mod_cas(l)= vt_prof_cas(nlev_cas)                                 !jyg
    2857          dq_mod_cas(l)= dq_prof_cas(nlev_cas)*fact
    2858          hq_mod_cas(l)= hq_prof_cas(nlev_cas)*fact                            !jyg
    2859          vq_mod_cas(l)= vq_prof_cas(nlev_cas)*fact                            !jyg
    2860          dtrad_mod_cas(l)= dtrad_prof_cas(nlev_cas)*fact                      !jyg
    2861  
    2862         endif ! play
    2863  
    2864        enddo ! l
    2865 
    2866 !       do l = 1,llm
    2867 !       print *,'t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l) ',
    2868 !     $        l,t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l)
    2869 !       enddo
    2870  
    2871           return
    2872           end
    2873 !*****************************************************************************
    2874 !=====================================================================
    2875        SUBROUTINE interp_dice_vertical(play,nlev_dice,nt_dice,plev_prof   &
    2876      &         ,th_prof,qv_prof,u_prof,v_prof,o3_prof                     &
    2877      &         ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof         &
    2878      &         ,th_mod,qv_mod,u_mod,v_mod,o3_mod                          &
    2879      &         ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)
    2880  
    2881        implicit none
    2882  
    2883 #include "dimensions.h"
    2884 
    2885 !-------------------------------------------------------------------------
    2886 ! Vertical interpolation of Dice forcing data onto model levels
    2887 !-------------------------------------------------------------------------
    2888  
    2889        integer nlevmax
    2890        parameter (nlevmax=41)
    2891        integer nlev_dice,mxcalc,nt_dice
    2892  
    2893        real play(llm), plev_prof(nlev_dice)
    2894        real th_prof(nlev_dice),qv_prof(nlev_dice)
    2895        real u_prof(nlev_dice),v_prof(nlev_dice)
    2896        real o3_prof(nlev_dice)
    2897        real ht_prof(nlev_dice),hq_prof(nlev_dice)
    2898        real hu_prof(nlev_dice),hv_prof(nlev_dice)
    2899        real w_prof(nlev_dice),omega_prof(nlev_dice)
    2900  
    2901        real th_mod(llm),qv_mod(llm)
    2902        real u_mod(llm),v_mod(llm), o3_mod(llm)
    2903        real ht_mod(llm),hq_mod(llm)
    2904        real hu_mod(llm),hv_mod(llm),w_mod(llm),omega_mod(llm)
    2905  
    2906        integer l,k,k1,k2,kp
    2907        real aa,frac,frac1,frac2,fact
    2908  
    2909        do l = 1, llm
    2910 
    2911         if (play(l).ge.plev_prof(nlev_dice)) then
    2912  
    2913         mxcalc=l
    2914          k1=0
    2915          k2=0
    2916 
    2917          if (play(l).le.plev_prof(1)) then
    2918 
    2919          do k = 1, nlev_dice-1
    2920           if (play(l).le.plev_prof(k) .and. play(l).gt.plev_prof(k+1)) then
    2921             k1=k
    2922             k2=k+1
    2923           endif
    2924          enddo
    2925 
    2926          if (k1.eq.0 .or. k2.eq.0) then
    2927           write(*,*) 'PB! k1, k2 = ',k1,k2
    2928           write(*,*) 'l,play(l) = ',l,play(l)/100
    2929          do k = 1, nlev_dice-1
    2930           write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/100
    2931          enddo
    2932          endif
    2933 
    2934          frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))
    2935          th_mod(l)= th_prof(k2) - frac*(th_prof(k2)-th_prof(k1))
    2936          qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))
    2937          u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))
    2938          v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))
    2939          o3_mod(l)= o3_prof(k2) - frac*(o3_prof(k2)-o3_prof(k1))
    2940          ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))
    2941          hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))
    2942          hu_mod(l)= hu_prof(k2) - frac*(hu_prof(k2)-hu_prof(k1))
    2943          hv_mod(l)= hv_prof(k2) - frac*(hv_prof(k2)-hv_prof(k1))
    2944          w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))
    2945          omega_mod(l)= omega_prof(k2) - frac*(omega_prof(k2)-omega_prof(k1))
    2946      
    2947          else !play>plev_prof(1)
    2948 
    2949          k1=1
    2950          k2=2
    2951          frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))
    2952          frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))
    2953          th_mod(l)= frac1*th_prof(k1) - frac2*th_prof(k2)
    2954          qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)
    2955          u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)
    2956          v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)
    2957          o3_mod(l)= frac1*o3_prof(k1) - frac2*o3_prof(k2)
    2958          ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)
    2959          hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)
    2960          hu_mod(l)= frac1*hu_prof(k1) - frac2*hu_prof(k2)
    2961          hv_mod(l)= frac1*hv_prof(k1) - frac2*hv_prof(k2)
    2962          w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)
    2963          omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)
    2964 
    2965          endif ! play.le.plev_prof(1)
    2966 
    2967         else ! above max altitude of forcing file
    2968  
    2969 !jyg
    2970          fact=20.*(plev_prof(nlev_dice)-play(l))/plev_prof(nlev_dice) !jyg
    2971          fact = max(fact,0.)                                           !jyg
    2972          fact = exp(-fact)                                             !jyg
    2973          th_mod(l)= th_prof(nlev_dice)                                 !jyg
    2974          qv_mod(l)= qv_prof(nlev_dice)*fact                            !jyg
    2975          u_mod(l)= u_prof(nlev_dice)*fact                              !jyg
    2976          v_mod(l)= v_prof(nlev_dice)*fact                              !jyg
    2977          o3_mod(l)= o3_prof(nlev_dice)*fact                            !jyg
    2978          ht_mod(l)= ht_prof(nlev_dice)                                 !jyg
    2979          hq_mod(l)= hq_prof(nlev_dice)*fact                            !jyg
    2980          hu_mod(l)= hu_prof(nlev_dice)                                 !jyg
    2981          hv_mod(l)= hv_prof(nlev_dice)                                 !jyg
    2982          w_mod(l)= 0.                                                  !jyg
    2983          omega_mod(l)= 0.                                              !jyg
    2984  
    2985         endif ! play
    2986  
    2987        enddo ! l
    2988 
    2989 !       do l = 1,llm
    2990 !       print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',
    2991 !     $        l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)
    2992 !       enddo
    2993  
    2994           return
    2995           end
    2996 
    2997 !======================================================================
    2998         SUBROUTINE interp_astex_time(day,day1,annee_ref                    &
    2999      &             ,year_ini_astex,day_ini_astex,nt_astex,dt_astex         &
    3000      &             ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex        &
    3001      &             ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof   &
    3002      &             ,ufa_prof,vfa_prof)
    3003         implicit none
    3004 
    3005 !---------------------------------------------------------------------------------------
    3006 ! Time interpolation of a 2D field to the timestep corresponding to day
    3007 !
    3008 ! day: current julian day (e.g. 717538.2)
    3009 ! day1: first day of the simulation
    3010 ! nt_astex: total nb of data in the forcing (e.g. 41 for Astex)
    3011 ! dt_astex: total time interval (in sec) between 2 forcing data (e.g. 1h for Astex)
    3012 !---------------------------------------------------------------------------------------
    3013 
    3014 ! inputs:
    3015         integer annee_ref
    3016         integer nt_astex,nlev_astex
    3017         integer year_ini_astex
    3018         real day, day1,day_ini_astex,dt_astex
    3019         real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)
    3020         real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)
    3021 ! outputs:
    3022         real div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof
    3023 ! local:
    3024         integer it_astex1, it_astex2
    3025         real timeit,time_astex1,time_astex2,frac
    3026 
    3027 ! Check that initial day of the simulation consistent with ASTEX period:
    3028        if (annee_ref.ne.1992 ) then
    3029         print*,'Pour Astex, annee_ref doit etre 1992 '
    3030         print*,'Changer annee_ref dans run.def'
    3031         stop
    3032        endif
    3033        if (annee_ref.eq.1992 .and. day1.lt.day_ini_astex) then
    3034         print*,'Astex debute le 13 Juin 1992 (jour julien=165)'
    3035         print*,'Changer dayref dans run.def'
    3036         stop
    3037        endif
    3038 
    3039 ! Determine timestep relative to the 1st day of TOGA-COARE:
    3040 !       timeit=(day-day1)*86400.
    3041 !       if (annee_ref.eq.1992) then
    3042 !        timeit=(day-day_ini_astex)*86400.
    3043 !       else
    3044 !        timeit=(day+2.-1.)*86400. ! 2 days between Jun13 and Jun15 1992
    3045 !       endif
    3046       timeit=(day-day_ini_astex)*86400
    3047 
    3048 ! Determine the closest observation times:
    3049        it_astex1=INT(timeit/dt_astex)+1
    3050        it_astex2=it_astex1 + 1
    3051        time_astex1=(it_astex1-1)*dt_astex
    3052        time_astex2=(it_astex2-1)*dt_astex
    3053        print *,'timeit day day_ini_astex',timeit,day,day_ini_astex
    3054        print *,'it_astex1,it_astex2,time_astex1,time_astex2',              &
    3055      &          it_astex1,it_astex2,time_astex1,time_astex2
    3056 
    3057        if (it_astex1 .ge. nt_astex) then
    3058         write(*,*) 'PB-stop: day, it_astex1, it_astex2, timeit: '          &
    3059      &        ,day,it_astex1,it_astex2,timeit/86400.
    3060         stop
    3061        endif
    3062 
    3063 ! time interpolation:
    3064        frac=(time_astex2-timeit)/(time_astex2-time_astex1)
    3065        frac=max(frac,0.0)
    3066 
    3067        div_prof = div_astex(it_astex2)                                     &
    3068      &          -frac*(div_astex(it_astex2)-div_astex(it_astex1))
    3069        ts_prof = ts_astex(it_astex2)                                        &
    3070      &          -frac*(ts_astex(it_astex2)-ts_astex(it_astex1))
    3071        ug_prof = ug_astex(it_astex2)                                       &
    3072      &          -frac*(ug_astex(it_astex2)-ug_astex(it_astex1))
    3073        vg_prof = vg_astex(it_astex2)                                       &
    3074      &          -frac*(vg_astex(it_astex2)-vg_astex(it_astex1))
    3075        ufa_prof = ufa_astex(it_astex2)                                     &
    3076      &          -frac*(ufa_astex(it_astex2)-ufa_astex(it_astex1))
    3077        vfa_prof = vfa_astex(it_astex2)                                     &
    3078      &          -frac*(vfa_astex(it_astex2)-vfa_astex(it_astex1))
    3079 
    3080          print*,                                                           &
    3081      &'day,annee_ref,day_ini_astex,timeit,it_astex1,it_astex2,SST:',       &
    3082      &day,annee_ref,day_ini_astex,timeit/86400.,it_astex1,                 &
    3083      &it_astex2,div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof
    3084 
    3085         return
    3086         END
    3087 
    3088 !======================================================================
    3089         SUBROUTINE interp_toga_time(day,day1,annee_ref                     &
    3090      &             ,year_ini_toga,day_ini_toga,nt_toga,dt_toga,nlev_toga   &
    3091      &             ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga   &
    3092      &             ,ht_toga,vt_toga,hq_toga,vq_toga                        &
    3093      &             ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof   &
    3094      &             ,ht_prof,vt_prof,hq_prof,vq_prof)
    3095         implicit none
    3096 
    3097 !---------------------------------------------------------------------------------------
    3098 ! Time interpolation of a 2D field to the timestep corresponding to day
    3099 !
    3100 ! day: current julian day (e.g. 717538.2)
    3101 ! day1: first day of the simulation
    3102 ! nt_toga: total nb of data in the forcing (e.g. 480 for TOGA-COARE)
    3103 ! dt_toga: total time interval (in sec) between 2 forcing data (e.g. 6h for TOGA-COARE)
    3104 !---------------------------------------------------------------------------------------
    3105 
    3106 #include "compar1d.h"
    3107 
    3108 ! inputs:
    3109         integer annee_ref
    3110         integer nt_toga,nlev_toga
    3111         integer year_ini_toga
    3112         real day, day1,day_ini_toga,dt_toga
    3113         real ts_toga(nt_toga)
    3114         real plev_toga(nlev_toga,nt_toga),t_toga(nlev_toga,nt_toga)
    3115         real q_toga(nlev_toga,nt_toga),u_toga(nlev_toga,nt_toga)
    3116         real v_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)
    3117         real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)
    3118         real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)
    3119 ! outputs:
    3120         real ts_prof
    3121         real plev_prof(nlev_toga),t_prof(nlev_toga)
    3122         real q_prof(nlev_toga),u_prof(nlev_toga)
    3123         real v_prof(nlev_toga),w_prof(nlev_toga)
    3124         real ht_prof(nlev_toga),vt_prof(nlev_toga)
    3125         real hq_prof(nlev_toga),vq_prof(nlev_toga)
    3126 ! local:
    3127         integer it_toga1, it_toga2,k
    3128         real timeit,time_toga1,time_toga2,frac
    3129 
    3130 
    3131         if (forcing_type.eq.2) then
    3132 ! Check that initial day of the simulation consistent with TOGA-COARE period:
    3133        if (annee_ref.ne.1992 .and. annee_ref.ne.1993) then
    3134         print*,'Pour TOGA-COARE, annee_ref doit etre 1992 ou 1993'
    3135         print*,'Changer annee_ref dans run.def'
    3136         stop
    3137        endif
    3138        if (annee_ref.eq.1992 .and. day1.lt.day_ini_toga) then
    3139         print*,'TOGA-COARE a debute le 1er Nov 1992 (jour julien=306)'
    3140         print*,'Changer dayref dans run.def'
    3141         stop
    3142        endif
    3143        if (annee_ref.eq.1993 .and. day1.gt.day_ini_toga+119) then
    3144         print*,'TOGA-COARE a fini le 28 Feb 1993 (jour julien=59)'
    3145         print*,'Changer dayref ou nday dans run.def'
    3146         stop
    3147        endif
    3148 
    3149        else if (forcing_type.eq.4) then
    3150 
    3151 ! Check that initial day of the simulation consistent with TWP-ICE period:
    3152        if (annee_ref.ne.2006) then
    3153         print*,'Pour TWP-ICE, annee_ref doit etre 2006'
    3154         print*,'Changer annee_ref dans run.def'
    3155         stop
    3156        endif
    3157        if (annee_ref.eq.2006 .and. day1.lt.day_ini_toga) then
    3158         print*,'TWP-ICE a debute le 17 Jan 2006 (jour julien=17)'
    3159         print*,'Changer dayref dans run.def'
    3160         stop
    3161        endif
    3162        if (annee_ref.eq.2006 .and. day1.gt.day_ini_toga+26) then
    3163         print*,'TWP-ICE a fini le 12 Feb 2006 (jour julien=43)'
    3164         print*,'Changer dayref ou nday dans run.def'
    3165         stop
    3166        endif
    3167 
    3168        endif
    3169 
    3170 ! Determine timestep relative to the 1st day of TOGA-COARE:
    3171 !       timeit=(day-day1)*86400.
    3172 !       if (annee_ref.eq.1992) then
    3173 !        timeit=(day-day_ini_toga)*86400.
    3174 !       else
    3175 !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
    3176 !       endif
    3177       timeit=(day-day_ini_toga)*86400
    3178 
    3179 ! Determine the closest observation times:
    3180        it_toga1=INT(timeit/dt_toga)+1
    3181        it_toga2=it_toga1 + 1
    3182        time_toga1=(it_toga1-1)*dt_toga
    3183        time_toga2=(it_toga2-1)*dt_toga
    3184 
    3185        if (it_toga1 .ge. nt_toga) then
    3186         write(*,*) 'PB-stop: day, it_toga1, it_toga2, timeit: '            &
    3187      &        ,day,it_toga1,it_toga2,timeit/86400.
    3188         stop
    3189        endif
    3190 
    3191 ! time interpolation:
    3192        frac=(time_toga2-timeit)/(time_toga2-time_toga1)
    3193        frac=max(frac,0.0)
    3194 
    3195        ts_prof = ts_toga(it_toga2)                                         &
    3196      &          -frac*(ts_toga(it_toga2)-ts_toga(it_toga1))
    3197 
    3198 !        print*,
    3199 !     :'day,annee_ref,day_ini_toga,timeit,it_toga1,it_toga2,SST:',
    3200 !     :day,annee_ref,day_ini_toga,timeit/86400.,it_toga1,it_toga2,ts_prof
    3201 
    3202        do k=1,nlev_toga
    3203         plev_prof(k) = 100.*(plev_toga(k,it_toga2)                         &
    3204      &          -frac*(plev_toga(k,it_toga2)-plev_toga(k,it_toga1)))
    3205         t_prof(k) = t_toga(k,it_toga2)                                     &
    3206      &          -frac*(t_toga(k,it_toga2)-t_toga(k,it_toga1))
    3207         q_prof(k) = q_toga(k,it_toga2)                                     &
    3208      &          -frac*(q_toga(k,it_toga2)-q_toga(k,it_toga1))
    3209         u_prof(k) = u_toga(k,it_toga2)                                     &
    3210      &          -frac*(u_toga(k,it_toga2)-u_toga(k,it_toga1))
    3211         v_prof(k) = v_toga(k,it_toga2)                                     &
    3212      &          -frac*(v_toga(k,it_toga2)-v_toga(k,it_toga1))
    3213         w_prof(k) = w_toga(k,it_toga2)                                     &
    3214      &          -frac*(w_toga(k,it_toga2)-w_toga(k,it_toga1))
    3215         ht_prof(k) = ht_toga(k,it_toga2)                                   &
    3216      &          -frac*(ht_toga(k,it_toga2)-ht_toga(k,it_toga1))
    3217         vt_prof(k) = vt_toga(k,it_toga2)                                   &
    3218      &          -frac*(vt_toga(k,it_toga2)-vt_toga(k,it_toga1))
    3219         hq_prof(k) = hq_toga(k,it_toga2)                                   &
    3220      &          -frac*(hq_toga(k,it_toga2)-hq_toga(k,it_toga1))
    3221         vq_prof(k) = vq_toga(k,it_toga2)                                   &
    3222      &          -frac*(vq_toga(k,it_toga2)-vq_toga(k,it_toga1))
    3223         enddo
    3224 
    3225         return
    3226         END
    3227 
    3228 !======================================================================
    3229         SUBROUTINE interp_dice_time(day,day1,annee_ref                    &
    3230      &             ,year_ini_dice,day_ini_dice,nt_dice,dt_dice            &
    3231      &             ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice       &
    3232      &             ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice         &
    3233      &             ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice     &
    3234      &             ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof         &
    3235      &             ,ustar_prof,psurf_prof,ug_prof,vg_prof                 &
    3236      &             ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof)
    3237         implicit none
    3238 
    3239 !---------------------------------------------------------------------------------------
    3240 ! Time interpolation of a 2D field to the timestep corresponding to day
    3241 !
    3242 ! day: current julian day (e.g. 717538.2)
    3243 ! day1: first day of the simulation
    3244 ! nt_dice: total nb of data in the forcing (e.g. 145 for Dice)
    3245 ! dt_dice: total time interval (in sec) between 2 forcing data (e.g. 30min. for Dice)
    3246 !---------------------------------------------------------------------------------------
    3247 
    3248 #include "compar1d.h"
    3249 
    3250 ! inputs:
    3251         integer annee_ref
    3252         integer nt_dice,nlev_dice
    3253         integer year_ini_dice
    3254         real day, day1,day_ini_dice,dt_dice
    3255         real shf_dice(nt_dice),lhf_dice(nt_dice),lwup_dice(nt_dice)
    3256         real swup_dice(nt_dice),tg_dice(nt_dice),ustar_dice(nt_dice)
    3257         real psurf_dice(nt_dice),ug_dice(nt_dice),vg_dice(nt_dice)
    3258         real ht_dice(nlev_dice,nt_dice),hq_dice(nlev_dice,nt_dice)
    3259         real hu_dice(nlev_dice,nt_dice),hv_dice(nlev_dice,nt_dice)
    3260         real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)
    3261 ! outputs:
    3262         real tg_prof,shf_prof,lhf_prof,lwup_prof,swup_prof
    3263         real ustar_prof,psurf_prof,ug_prof,vg_prof
    3264         real ht_prof(nlev_dice),hq_prof(nlev_dice)
    3265         real hu_prof(nlev_dice),hv_prof(nlev_dice)
    3266         real w_prof(nlev_dice),omega_prof(nlev_dice)
    3267 ! local:
    3268         integer it_dice1, it_dice2,k
    3269         real timeit,time_dice1,time_dice2,frac
    3270 
    3271 
    3272         if (forcing_type.eq.7) then
    3273 ! Check that initial day of the simulation consistent with Dice period:
    3274        print *,'annee_ref=',annee_ref
    3275        print *,'day1=',day1
    3276        print *,'day_ini_dice=',day_ini_dice
    3277        if (annee_ref.ne.1999) then
    3278         print*,'Pour Dice, annee_ref doit etre 1999'
    3279         print*,'Changer annee_ref dans run.def'
    3280         stop
    3281        endif
    3282        if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice) then
    3283         print*,'Dice a debute le 23 Oct 1999 (jour julien=296)'
    3284         print*,'Changer dayref dans run.def',day1,day_ini_dice
    3285         stop
    3286        endif
    3287        if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice+2) then
    3288         print*,'Dice a fini le 25 Oct 1999 (jour julien=298)'
    3289         print*,'Changer dayref ou nday dans run.def',day1,day_ini_dice
    3290         stop
    3291        endif
    3292 
    3293        endif
    3294 
    3295 ! Determine timestep relative to the 1st day of TOGA-COARE:
    3296 !       timeit=(day-day1)*86400.
    3297 !       if (annee_ref.eq.1992) then
    3298 !        timeit=(day-day_ini_dice)*86400.
    3299 !       else
    3300 !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
    3301 !       endif
    3302       timeit=(day-day_ini_dice)*86400
    3303 
    3304 ! Determine the closest observation times:
    3305        it_dice1=INT(timeit/dt_dice)+1
    3306        it_dice2=it_dice1 + 1
    3307        time_dice1=(it_dice1-1)*dt_dice
    3308        time_dice2=(it_dice2-1)*dt_dice
    3309 
    3310        if (it_dice1 .ge. nt_dice) then
    3311         write(*,*) 'PB-stop: day, it_dice1, it_dice2, timeit: ',day,it_dice1,it_dice2,timeit/86400.
    3312         stop
    3313        endif
    3314 
    3315 ! time interpolation:
    3316        frac=(time_dice2-timeit)/(time_dice2-time_dice1)
    3317        frac=max(frac,0.0)
    3318 
    3319        shf_prof = shf_dice(it_dice2)-frac*(shf_dice(it_dice2)-shf_dice(it_dice1))
    3320        lhf_prof = lhf_dice(it_dice2)-frac*(lhf_dice(it_dice2)-lhf_dice(it_dice1))
    3321        lwup_prof = lwup_dice(it_dice2)-frac*(lwup_dice(it_dice2)-lwup_dice(it_dice1))
    3322        swup_prof = swup_dice(it_dice2)-frac*(swup_dice(it_dice2)-swup_dice(it_dice1))
    3323        tg_prof = tg_dice(it_dice2)-frac*(tg_dice(it_dice2)-tg_dice(it_dice1))
    3324        ustar_prof = ustar_dice(it_dice2)-frac*(ustar_dice(it_dice2)-ustar_dice(it_dice1))
    3325        psurf_prof = psurf_dice(it_dice2)-frac*(psurf_dice(it_dice2)-psurf_dice(it_dice1))
    3326        ug_prof = ug_dice(it_dice2)-frac*(ug_dice(it_dice2)-ug_dice(it_dice1))
    3327        vg_prof = vg_dice(it_dice2)-frac*(vg_dice(it_dice2)-vg_dice(it_dice1))
    3328 
    3329 !        print*,
    3330 !     :'day,annee_ref,day_ini_dice,timeit,it_dice1,it_dice2,SST:',
    3331 !     :day,annee_ref,day_ini_dice,timeit/86400.,it_dice1,it_dice2,ts_prof
    3332 
    3333        do k=1,nlev_dice
    3334         ht_prof(k) = ht_dice(k,it_dice2)-frac*(ht_dice(k,it_dice2)-ht_dice(k,it_dice1))
    3335         hq_prof(k) = hq_dice(k,it_dice2)-frac*(hq_dice(k,it_dice2)-hq_dice(k,it_dice1))
    3336         hu_prof(k) = hu_dice(k,it_dice2)-frac*(hu_dice(k,it_dice2)-hu_dice(k,it_dice1))
    3337         hv_prof(k) = hv_dice(k,it_dice2)-frac*(hv_dice(k,it_dice2)-hv_dice(k,it_dice1))
    3338         w_prof(k) = w_dice(k,it_dice2)-frac*(w_dice(k,it_dice2)-w_dice(k,it_dice1))
    3339         omega_prof(k) = omega_dice(k,it_dice2)-frac*(omega_dice(k,it_dice2)-omega_dice(k,it_dice1))
    3340         enddo
    3341 
    3342         return
    3343         END
    3344 
    3345 !======================================================================
    3346         SUBROUTINE interp_gabls4_time(day,day1,annee_ref                              &
    3347      &             ,year_ini_gabls4,day_ini_gabls4,nt_gabls4,dt_gabls4,nlev_gabls4    &
    3348      &             ,ug_gabls4,vg_gabls4,ht_gabls4,hq_gabls4,tg_gabls4                          &
    3349      &             ,ug_prof,vg_prof,ht_prof,hq_prof,tg_prof)
    3350         implicit none
    3351 
    3352 !---------------------------------------------------------------------------------------
    3353 ! Time interpolation of a 2D field to the timestep corresponding to day
    3354 !
    3355 ! day: current julian day
    3356 ! day1: first day of the simulation
    3357 ! nt_gabls4: total nb of data in the forcing (e.g. 37 for gabls4)
    3358 ! dt_gabls4: total time interval (in sec) between 2 forcing data (e.g. 60min. for gabls4)
    3359 !---------------------------------------------------------------------------------------
    3360 
    3361 #include "compar1d.h"
    3362 
    3363 ! inputs:
    3364         integer annee_ref
    3365         integer nt_gabls4,nlev_gabls4
    3366         integer year_ini_gabls4
    3367         real day, day1,day_ini_gabls4,dt_gabls4
    3368         real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4)
    3369         real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4)
    3370         real tg_gabls4(nt_gabls4), tg_prof
    3371 ! outputs:
    3372         real ug_prof(nlev_gabls4),vg_prof(nlev_gabls4)
    3373         real ht_prof(nlev_gabls4),hq_prof(nlev_gabls4)
    3374 ! local:
    3375         integer it_gabls41, it_gabls42,k
    3376         real timeit,time_gabls41,time_gabls42,frac
    3377 
    3378 
    3379 
    3380 ! Check that initial day of the simulation consistent with gabls4 period:
    3381        if (forcing_type.eq.8 ) then
    3382        print *,'annee_ref=',annee_ref
    3383        print *,'day1=',day1
    3384        print *,'day_ini_gabls4=',day_ini_gabls4
    3385        if (annee_ref.ne.2009) then
    3386         print*,'Pour gabls4, annee_ref doit etre 2009'
    3387         print*,'Changer annee_ref dans run.def'
    3388         stop
    3389        endif
    3390        if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4) then
    3391         print*,'gabls4 a debute le 11 dec 2009 (jour julien=345)'
    3392         print*,'Changer dayref dans run.def',day1,day_ini_gabls4
    3393         stop
    3394        endif
    3395        if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4+2) then
    3396         print*,'gabls4 a fini le 12 dec 2009 (jour julien=346)'
    3397         print*,'Changer dayref ou nday dans run.def',day1,day_ini_gabls4
    3398         stop
    3399        endif
    3400        endif
    3401 
    3402       timeit=(day-day_ini_gabls4)*86400
    3403        print *,'day,day_ini_gabls4=',day,day_ini_gabls4
    3404        print *,'nt_gabls4,dt,timeit=',nt_gabls4,dt_gabls4,timeit
    3405 
    3406 ! Determine the closest observation times:
    3407        it_gabls41=INT(timeit/dt_gabls4)+1
    3408        it_gabls42=it_gabls41 + 1
    3409        time_gabls41=(it_gabls41-1)*dt_gabls4
    3410        time_gabls42=(it_gabls42-1)*dt_gabls4
    3411 
    3412        if (it_gabls41 .ge. nt_gabls4) then
    3413         write(*,*) 'PB-stop: day, it_gabls41, it_gabls42, timeit: ',day,it_gabls41,it_gabls42,timeit/86400.
    3414         stop
    3415        endif
    3416 
    3417 ! time interpolation:
    3418        frac=(time_gabls42-timeit)/(time_gabls42-time_gabls41)
    3419        frac=max(frac,0.0)
    3420 
    3421 
    3422        do k=1,nlev_gabls4
    3423         ug_prof(k) = ug_gabls4(k,it_gabls42)-frac*(ug_gabls4(k,it_gabls42)-ug_gabls4(k,it_gabls41))
    3424         vg_prof(k) = vg_gabls4(k,it_gabls42)-frac*(vg_gabls4(k,it_gabls42)-vg_gabls4(k,it_gabls41))
    3425         ht_prof(k) = ht_gabls4(k,it_gabls42)-frac*(ht_gabls4(k,it_gabls42)-ht_gabls4(k,it_gabls41))
    3426         hq_prof(k) = hq_gabls4(k,it_gabls42)-frac*(hq_gabls4(k,it_gabls42)-hq_gabls4(k,it_gabls41))
    3427         enddo
    3428         tg_prof=tg_gabls4(it_gabls42)-frac*(tg_gabls4(it_gabls42)-tg_gabls4(it_gabls41))
    3429         return
    3430         END
    3431 
    3432 !======================================================================
    3433         SUBROUTINE interp_armcu_time(day,day1,annee_ref                    &
    3434      &             ,year_ini_armcu,day_ini_armcu,nt_armcu,dt_armcu         &
    3435      &             ,nlev_armcu,fs_armcu,fl_armcu,at_armcu,rt_armcu         &
    3436      &             ,aqt_armcu,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof)
    3437         implicit none
    3438 
    3439 !---------------------------------------------------------------------------------------
    3440 ! Time interpolation of a 2D field to the timestep corresponding to day
    3441 !
    3442 ! day: current julian day (e.g. 717538.2)
    3443 ! day1: first day of the simulation
    3444 ! nt_armcu: total nb of data in the forcing (e.g. 31 for armcu)
    3445 ! dt_armcu: total time interval (in sec) between 2 forcing data (e.g. 1/2h for armcu)
    3446 ! fs= sensible flux
    3447 ! fl= latent flux
    3448 ! at,rt,aqt= advective and radiative tendencies
    3449 !---------------------------------------------------------------------------------------
    3450 
    3451 ! inputs:
    3452         integer annee_ref
    3453         integer nt_armcu,nlev_armcu
    3454         integer year_ini_armcu
    3455         real day, day1,day_ini_armcu,dt_armcu
    3456         real fs_armcu(nt_armcu),fl_armcu(nt_armcu),at_armcu(nt_armcu)
    3457         real rt_armcu(nt_armcu),aqt_armcu(nt_armcu)
    3458 ! outputs:
    3459         real fs_prof,fl_prof,at_prof,rt_prof,aqt_prof
    3460 ! local:
    3461         integer it_armcu1, it_armcu2,k
    3462         real timeit,time_armcu1,time_armcu2,frac
    3463 
    3464 ! Check that initial day of the simulation consistent with ARMCU period:
    3465        if (annee_ref.ne.1997 ) then
    3466         print*,'Pour ARMCU, annee_ref doit etre 1997 '
    3467         print*,'Changer annee_ref dans run.def'
    3468         stop
    3469        endif
    3470 
    3471       timeit=(day-day_ini_armcu)*86400
    3472 
    3473 ! Determine the closest observation times:
    3474        it_armcu1=INT(timeit/dt_armcu)+1
    3475        it_armcu2=it_armcu1 + 1
    3476        time_armcu1=(it_armcu1-1)*dt_armcu
    3477        time_armcu2=(it_armcu2-1)*dt_armcu
    3478        print *,'timeit day day_ini_armcu',timeit,day,day_ini_armcu
    3479        print *,'it_armcu1,it_armcu2,time_armcu1,time_armcu2',              &
    3480      &          it_armcu1,it_armcu2,time_armcu1,time_armcu2
    3481 
    3482        if (it_armcu1 .ge. nt_armcu) then
    3483         write(*,*) 'PB-stop: day, it_armcu1, it_armcu2, timeit: '          &
    3484      &        ,day,it_armcu1,it_armcu2,timeit/86400.
    3485         stop
    3486        endif
    3487 
    3488 ! time interpolation:
    3489        frac=(time_armcu2-timeit)/(time_armcu2-time_armcu1)
    3490        frac=max(frac,0.0)
    3491 
    3492        fs_prof = fs_armcu(it_armcu2)                                       &
    3493      &          -frac*(fs_armcu(it_armcu2)-fs_armcu(it_armcu1))
    3494        fl_prof = fl_armcu(it_armcu2)                                       &
    3495      &          -frac*(fl_armcu(it_armcu2)-fl_armcu(it_armcu1))
    3496        at_prof = at_armcu(it_armcu2)                                       &
    3497      &          -frac*(at_armcu(it_armcu2)-at_armcu(it_armcu1))
    3498        rt_prof = rt_armcu(it_armcu2)                                       &
    3499      &          -frac*(rt_armcu(it_armcu2)-rt_armcu(it_armcu1))
    3500        aqt_prof = aqt_armcu(it_armcu2)                                       &
    3501      &          -frac*(aqt_armcu(it_armcu2)-aqt_armcu(it_armcu1))
    3502 
    3503          print*,                                                           &
    3504      &'day,annee_ref,day_ini_armcu,timeit,it_armcu1,it_armcu2,SST:',       &
    3505      &day,annee_ref,day_ini_armcu,timeit/86400.,it_armcu1,                 &
    3506      &it_armcu2,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof
    3507 
    3508         return
    3509         END
    3510 
    3511 !=====================================================================
    3512       subroutine readprofiles(nlev_max,kmax,ntrac,height,                  &
    3513      &           thlprof,qtprof,uprof,                                     &
    3514      &           vprof,e12prof,ugprof,vgprof,                              &
    3515      &           wfls,dqtdxls,dqtdyls,dqtdtls,                             &
    3516      &           thlpcar,tracer,nt1,nt2)
    3517       implicit none
    3518 
    3519         integer nlev_max,kmax,kmax2,ntrac
    3520         logical :: llesread = .true.
    3521 
    3522         real height(nlev_max),thlprof(nlev_max),qtprof(nlev_max),          &
    3523      &       uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max),            &
    3524      &       ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max),             &
    3525      &       dqtdxls(nlev_max),dqtdyls(nlev_max),dqtdtls(nlev_max),        &
    3526      &           thlpcar(nlev_max),tracer(nlev_max,ntrac)
    3527 
    3528         real height1(nlev_max)
    3529 
    3530         integer, parameter :: ilesfile=1
    3531         integer :: ierr,k,itrac,nt1,nt2
    3532 
    3533         if(.not.(llesread)) return
    3534 
    3535        open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
    3536         if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
    3537         read (ilesfile,*) kmax
    3538         do k=1,kmax
    3539           read (ilesfile,*) height1(k),thlprof(k),qtprof (k),               &
    3540      &                      uprof (k),vprof  (k),e12prof(k)
    3541         enddo
    3542         close(ilesfile)
    3543 
    3544        open(ilesfile,file='lscale.inp.001',status='old',iostat=ierr)
    3545         if (ierr /= 0) stop 'ERROR:Lscale.inp does not exist'
    3546         read (ilesfile,*) kmax2
    3547         if (kmax .ne. kmax2) then
    3548           print *, 'fichiers prof.inp et lscale.inp incompatibles :'
    3549           print *, 'nbre de niveaux : ',kmax,' et ',kmax2
    3550           stop 'lecture profiles'
    3551         endif
    3552         do k=1,kmax
    3553           read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k),         &
    3554      &                      dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k)
    3555         end do
    3556         do k=1,kmax
    3557           if (height(k) .ne. height1(k)) then
    3558             print *, 'fichiers prof.inp et lscale.inp incompatibles :'
    3559             print *, 'les niveaux different : ',k,height1(k), height(k)
    3560             stop
    3561           endif
    3562         end do
    3563         close(ilesfile)
    3564 
    3565        open(ilesfile,file='trac.inp.001',status='old',iostat=ierr)
    3566         if (ierr /= 0) then
    3567             print*,'WARNING : trac.inp does not exist'
    3568         else
    3569         read (ilesfile,*) kmax2,nt1,nt2
    3570         if (nt2>ntrac) then
    3571           stop 'Augmenter le nombre de traceurs dans traceur.def'
    3572         endif
    3573         if (kmax .ne. kmax2) then
    3574           print *, 'fichiers prof.inp et lscale.inp incompatibles :'
    3575           print *, 'nbre de niveaux : ',kmax,' et ',kmax2
    3576           stop 'lecture profiles'
    3577         endif
    3578         do k=1,kmax
    3579           read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2)
    3580         end do
    3581         close(ilesfile)
    3582         endif
    3583 
    3584         return
    3585         end
    3586 !======================================================================
    3587       subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof,       &
    3588      &       thlprof,qprof,uprof,vprof,wprof,omega,o3mmr)
    3589 !======================================================================
    3590       implicit none
    3591 
    3592         integer nlev_max,kmax
    3593         logical :: llesread = .true.
    3594 
    3595         real height(nlev_max),pprof(nlev_max),tprof(nlev_max)
    3596         real thlprof(nlev_max)
    3597         real qprof(nlev_max),uprof(nlev_max),vprof(nlev_max)
    3598         real wprof(nlev_max),omega(nlev_max),o3mmr(nlev_max)
    3599 
    3600         integer, parameter :: ilesfile=1
    3601         integer :: k,ierr
    3602 
    3603         if(.not.(llesread)) return
    3604 
    3605        open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
    3606         if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
    3607         read (ilesfile,*) kmax
    3608         do k=1,kmax
    3609           read (ilesfile,*) height(k),pprof(k),  tprof(k),thlprof(k),      &
    3610      &                      qprof (k),uprof(k),  vprof(k),  wprof(k),      &
    3611      &                      omega (k),o3mmr(k)
    3612         enddo
    3613         close(ilesfile)
    3614 
    3615         return
    3616         end
    3617 
    3618 !======================================================================
    3619       subroutine readprofile_astex(nlev_max,kmax,height,pprof,tprof,       &
    3620      &    thlprof,qvprof,qlprof,qtprof,uprof,vprof,wprof,tkeprof,o3mmr)
    3621 !======================================================================
    3622       implicit none
    3623 
    3624         integer nlev_max,kmax
    3625         logical :: llesread = .true.
    3626 
    3627         real height(nlev_max),pprof(nlev_max),tprof(nlev_max),             &
    3628      &  thlprof(nlev_max),qlprof(nlev_max),qtprof(nlev_max),               &
    3629      &  qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max),                  &
    3630      &  wprof(nlev_max),tkeprof(nlev_max),o3mmr(nlev_max)
    3631 
    3632         integer, parameter :: ilesfile=1
    3633         integer :: ierr,k
    3634 
    3635         if(.not.(llesread)) return
    3636 
    3637        open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)
    3638         if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
    3639         read (ilesfile,*) kmax
    3640         do k=1,kmax
    3641           read (ilesfile,*) height(k),pprof(k),  tprof(k),thlprof(k),      &
    3642      &                qvprof (k),qlprof (k),qtprof (k),                    &
    3643      &                uprof(k),  vprof(k),  wprof(k),tkeprof(k),o3mmr(k)
    3644         enddo
    3645         close(ilesfile)
    3646 
    3647         return
    3648         end
    3649 
    3650 
    3651 
    3652 !======================================================================
    3653       subroutine readprofile_armcu(nlev_max,kmax,height,pprof,uprof,       &
    3654      &       vprof,thetaprof,tprof,qvprof,rvprof,aprof,bprof)
    3655 !======================================================================
    3656       implicit none
    3657 
    3658         integer nlev_max,kmax
    3659         logical :: llesread = .true.
    3660 
    3661         real height(nlev_max),pprof(nlev_max),tprof(nlev_max)
    3662         real thetaprof(nlev_max),rvprof(nlev_max)
    3663         real qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max)
    3664         real aprof(nlev_max+1),bprof(nlev_max+1)
    3665 
    3666         integer, parameter :: ilesfile=1
    3667         integer, parameter :: ifile=2
    3668         integer :: ierr,jtot,k
    3669 
    3670         if(.not.(llesread)) return
    3671 
    3672 ! Read profiles at full levels
    3673        IF(nlev_max.EQ.19) THEN
    3674        open (ilesfile,file='prof.inp.19',status='old',iostat=ierr)
    3675        print *,'On ouvre prof.inp.19'
    3676        ELSE
    3677        open (ilesfile,file='prof.inp.40',status='old',iostat=ierr)
    3678        print *,'On ouvre prof.inp.40'
    3679        ENDIF
    3680         if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'
    3681         read (ilesfile,*) kmax
    3682         do k=1,kmax
    3683           read (ilesfile,*) height(k)    ,pprof(k),  uprof(k), vprof(k),   &
    3684      &                      thetaprof(k) ,tprof(k), qvprof(k),rvprof(k)
    3685         enddo
    3686         close(ilesfile)
    3687 
    3688 ! Vertical coordinates half levels for eta-coordinates (plev = alpha + beta * psurf)
    3689        IF(nlev_max.EQ.19) THEN
    3690        open (ifile,file='proh.inp.19',status='old',iostat=ierr)
    3691        print *,'On ouvre proh.inp.19'
    3692        if (ierr /= 0) stop 'ERROR:Proh.inp.19 does not exist'
    3693        ELSE
    3694        open (ifile,file='proh.inp.40',status='old',iostat=ierr)
    3695        print *,'On ouvre proh.inp.40'
    3696        if (ierr /= 0) stop 'ERROR:Proh.inp.40 does not exist'
    3697        ENDIF
    3698         read (ifile,*) kmax
    3699         do k=1,kmax
    3700           read (ifile,*) jtot,aprof(k),bprof(k)
    3701         enddo
    3702         close(ifile)
    3703 
    3704         return
    3705         end
    3706 
    3707 !=====================================================================
    3708       subroutine read_fire(fich_fire,nlevel,ntime                          &
    3709      &     ,zz,thl,qt,u,v,tke                                              &
    3710      &     ,ug,vg,wls,dqtdx,dqtdy,dqtdt,thl_rad)
    3711 
    3712 !program reading forcings of the FIRE case study
    3713 
    3714 
    3715       implicit none
    3716 
    3717 #include "netcdf.inc"
    3718 
    3719       integer ntime,nlevel
    3720       character*80 :: fich_fire
    3721       real*8 zz(nlevel)
    3722 
    3723       real*8 thl(nlevel)
    3724       real*8 qt(nlevel),u(nlevel)
    3725       real*8 v(nlevel),tke(nlevel)
    3726       real*8 ug(nlevel,ntime),vg(nlevel,ntime),wls(nlevel,ntime)
    3727       real*8 dqtdx(nlevel,ntime),dqtdy(nlevel,ntime)
    3728       real*8 dqtdt(nlevel,ntime),thl_rad(nlevel,ntime)
    3729 
    3730       integer nid, ierr
    3731       integer nbvar3d
    3732       parameter(nbvar3d=30)
    3733       integer var3didin(nbvar3d)
    3734 
    3735       ierr = NF_OPEN(fich_fire,NF_NOWRITE,nid)
    3736       if (ierr.NE.NF_NOERR) then
    3737          write(*,*) 'ERROR: Pb opening forcings nc file '
    3738          write(*,*) NF_STRERROR(ierr)
    3739          stop ""
    3740       endif
    3741 
    3742 
    3743        ierr=NF_INQ_VARID(nid,"zz",var3didin(1))
    3744          if(ierr/=NF_NOERR) then
    3745            write(*,*) NF_STRERROR(ierr)
    3746            stop 'lev'
    3747          endif
    3748 
    3749 
    3750       ierr=NF_INQ_VARID(nid,"thetal",var3didin(2))
    3751          if(ierr/=NF_NOERR) then
    3752            write(*,*) NF_STRERROR(ierr)
    3753            stop 'temp'
    3754          endif
    3755 
    3756       ierr=NF_INQ_VARID(nid,"qt",var3didin(3))
    3757          if(ierr/=NF_NOERR) then
    3758            write(*,*) NF_STRERROR(ierr)
    3759            stop 'qv'
    3760          endif
    3761 
    3762       ierr=NF_INQ_VARID(nid,"u",var3didin(4))
    3763          if(ierr/=NF_NOERR) then
    3764            write(*,*) NF_STRERROR(ierr)
    3765            stop 'u'
    3766          endif
    3767 
    3768       ierr=NF_INQ_VARID(nid,"v",var3didin(5))
    3769          if(ierr/=NF_NOERR) then
    3770            write(*,*) NF_STRERROR(ierr)
    3771            stop 'v'
    3772          endif
    3773 
    3774       ierr=NF_INQ_VARID(nid,"tke",var3didin(6))
    3775          if(ierr/=NF_NOERR) then
    3776            write(*,*) NF_STRERROR(ierr)
    3777            stop 'tke'
    3778          endif
    3779 
    3780       ierr=NF_INQ_VARID(nid,"ugeo",var3didin(7))
    3781          if(ierr/=NF_NOERR) then
    3782            write(*,*) NF_STRERROR(ierr)
    3783            stop 'ug'
    3784          endif
    3785 
    3786       ierr=NF_INQ_VARID(nid,"vgeo",var3didin(8))
    3787          if(ierr/=NF_NOERR) then
    3788            write(*,*) NF_STRERROR(ierr)
    3789            stop 'vg'
    3790          endif
    3791      
    3792       ierr=NF_INQ_VARID(nid,"wls",var3didin(9))
    3793          if(ierr/=NF_NOERR) then
    3794            write(*,*) NF_STRERROR(ierr)
    3795            stop 'wls'
    3796          endif
    3797 
    3798       ierr=NF_INQ_VARID(nid,"dqtdx",var3didin(10))
    3799          if(ierr/=NF_NOERR) then
    3800            write(*,*) NF_STRERROR(ierr)
    3801            stop 'dqtdx'
    3802          endif
    3803 
    3804       ierr=NF_INQ_VARID(nid,"dqtdy",var3didin(11))
    3805          if(ierr/=NF_NOERR) then
    3806            write(*,*) NF_STRERROR(ierr)
    3807            stop 'dqtdy'
    3808       endif
    3809 
    3810       ierr=NF_INQ_VARID(nid,"dqtdt",var3didin(12))
    3811          if(ierr/=NF_NOERR) then
    3812            write(*,*) NF_STRERROR(ierr)
    3813            stop 'dqtdt'
    3814       endif
    3815 
    3816       ierr=NF_INQ_VARID(nid,"thl_rad",var3didin(13))
    3817          if(ierr/=NF_NOERR) then
    3818            write(*,*) NF_STRERROR(ierr)
    3819            stop 'thl_rad'
    3820       endif
    3821 !dimensions lecture
    3822 !      call catchaxis(nid,ntime,nlevel,time,z,ierr)
    3823  
    3824 #ifdef NC_DOUBLE
    3825          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
    3826 #else
    3827          ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
    3828 #endif
    3829          if(ierr/=NF_NOERR) then
    3830             write(*,*) NF_STRERROR(ierr)
    3831             stop "getvarup"
    3832          endif
    3833 !          write(*,*)'lecture z ok',zz
    3834 
    3835 #ifdef NC_DOUBLE
    3836          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),thl)
    3837 #else
    3838          ierr = NF_GET_VAR_REAL(nid,var3didin(2),thl)
    3839 #endif
    3840          if(ierr/=NF_NOERR) then
    3841             write(*,*) NF_STRERROR(ierr)
    3842             stop "getvarup"
    3843          endif
    3844 !          write(*,*)'lecture thl ok',thl
    3845 
    3846 #ifdef NC_DOUBLE
    3847          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),qt)
    3848 #else
    3849          ierr = NF_GET_VAR_REAL(nid,var3didin(3),qt)
    3850 #endif
    3851          if(ierr/=NF_NOERR) then
    3852             write(*,*) NF_STRERROR(ierr)
    3853             stop "getvarup"
    3854          endif
    3855 !          write(*,*)'lecture qt ok',qt
    3856  
    3857 #ifdef NC_DOUBLE
    3858          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),u)
    3859 #else
    3860          ierr = NF_GET_VAR_REAL(nid,var3didin(4),u)
    3861 #endif
    3862          if(ierr/=NF_NOERR) then
    3863             write(*,*) NF_STRERROR(ierr)
    3864             stop "getvarup"
    3865          endif
    3866 !          write(*,*)'lecture u ok',u
    3867 
    3868 #ifdef NC_DOUBLE
    3869          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),v)
    3870 #else
    3871          ierr = NF_GET_VAR_REAL(nid,var3didin(5),v)
    3872 #endif
    3873          if(ierr/=NF_NOERR) then
    3874             write(*,*) NF_STRERROR(ierr)
    3875             stop "getvarup"
    3876          endif
    3877 !          write(*,*)'lecture v ok',v
    3878 
    3879 #ifdef NC_DOUBLE
    3880          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tke)
    3881 #else
    3882          ierr = NF_GET_VAR_REAL(nid,var3didin(6),tke)
    3883 #endif
    3884          if(ierr/=NF_NOERR) then
    3885             write(*,*) NF_STRERROR(ierr)
    3886             stop "getvarup"
    3887          endif
    3888 !          write(*,*)'lecture tke ok',tke
    3889 
    3890 #ifdef NC_DOUBLE
    3891          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ug)
    3892 #else
    3893          ierr = NF_GET_VAR_REAL(nid,var3didin(7),ug)
    3894 #endif
    3895          if(ierr/=NF_NOERR) then
    3896             write(*,*) NF_STRERROR(ierr)
    3897             stop "getvarup"
    3898          endif
    3899 !          write(*,*)'lecture ug ok',ug
    3900 
    3901 #ifdef NC_DOUBLE
    3902          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),vg)
    3903 #else
    3904          ierr = NF_GET_VAR_REAL(nid,var3didin(8),vg)
    3905 #endif
    3906          if(ierr/=NF_NOERR) then
    3907             write(*,*) NF_STRERROR(ierr)
    3908             stop "getvarup"
    3909          endif
    3910 !          write(*,*)'lecture vg ok',vg
    3911 
    3912 #ifdef NC_DOUBLE
    3913          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),wls)
    3914 #else
    3915          ierr = NF_GET_VAR_REAL(nid,var3didin(9),wls)
    3916 #endif
    3917          if(ierr/=NF_NOERR) then
    3918             write(*,*) NF_STRERROR(ierr)
    3919             stop "getvarup"
    3920          endif
    3921 !          write(*,*)'lecture wls ok',wls
    3922 
    3923 #ifdef NC_DOUBLE
    3924          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),dqtdx)
    3925 #else
    3926          ierr = NF_GET_VAR_REAL(nid,var3didin(10),dqtdx)
    3927 #endif
    3928          if(ierr/=NF_NOERR) then
    3929             write(*,*) NF_STRERROR(ierr)
    3930             stop "getvarup"
    3931          endif
    3932 !          write(*,*)'lecture dqtdx ok',dqtdx
    3933 
    3934 #ifdef NC_DOUBLE
    3935          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),dqtdy)
    3936 #else
    3937          ierr = NF_GET_VAR_REAL(nid,var3didin(11),dqtdy)
    3938 #endif
    3939          if(ierr/=NF_NOERR) then
    3940             write(*,*) NF_STRERROR(ierr)
    3941             stop "getvarup"
    3942          endif
    3943 !          write(*,*)'lecture dqtdy ok',dqtdy
    3944 
    3945 #ifdef NC_DOUBLE
    3946          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),dqtdt)
    3947 #else
    3948          ierr = NF_GET_VAR_REAL(nid,var3didin(12),dqtdt)
    3949 #endif
    3950          if(ierr/=NF_NOERR) then
    3951             write(*,*) NF_STRERROR(ierr)
    3952             stop "getvarup"
    3953          endif
    3954 !          write(*,*)'lecture dqtdt ok',dqtdt
    3955 
    3956 #ifdef NC_DOUBLE
    3957          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),thl_rad)
    3958 #else
    3959          ierr = NF_GET_VAR_REAL(nid,var3didin(13),thl_rad)
    3960 #endif
    3961          if(ierr/=NF_NOERR) then
    3962             write(*,*) NF_STRERROR(ierr)
    3963             stop "getvarup"
    3964          endif
    3965 !          write(*,*)'lecture thl_rad ok',thl_rad
    3966 
    3967          return
    3968          end subroutine read_fire
    3969 !=====================================================================
    3970       subroutine read_dice(fich_dice,nlevel,ntime                         &
    3971      &     ,zz,pres,t,qv,u,v,o3                                          &
    3972      &     ,shf,lhf,lwup,swup,tg,ustar,psurf,ug,vg                        &
    3973      &     ,hadvt,hadvq,hadvu,hadvv,w,omega)
    3974 
    3975 !program reading initial profils and forcings of the Dice case study
    3976 
    3977 
    3978       implicit none
    3979 
    3980 #include "netcdf.inc"
    3981 #include "YOMCST.h"
    3982 
    3983       integer ntime,nlevel
    3984       integer l,k
    3985       character*80 :: fich_dice
    3986       real*8 time(ntime)
    3987       real*8 zz(nlevel)
    3988 
    3989       real*8 th(nlevel),pres(nlevel),t(nlevel)
    3990       real*8 qv(nlevel),u(nlevel),v(nlevel),o3(nlevel)
    3991       real*8 shf(ntime),lhf(ntime),lwup(ntime),swup(ntime),tg(ntime)
    3992       real*8 ustar(ntime),psurf(ntime),ug(ntime),vg(ntime)
    3993       real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime),hadvu(nlevel,ntime)
    3994       real*8 hadvv(nlevel,ntime),w(nlevel,ntime),omega(nlevel,ntime)
    3995       real*8 pzero
    3996 
    3997       integer nid, ierr
    3998       integer nbvar3d
    3999       parameter(nbvar3d=30)
    4000       integer var3didin(nbvar3d)
    4001 
    4002       pzero=100000.
    4003       ierr = NF_OPEN(fich_dice,NF_NOWRITE,nid)
    4004       if (ierr.NE.NF_NOERR) then
    4005          write(*,*) 'ERROR: Pb opening forcings nc file '
    4006          write(*,*) NF_STRERROR(ierr)
    4007          stop ""
    4008       endif
    4009 
    4010 
    4011        ierr=NF_INQ_VARID(nid,"height",var3didin(1))
    4012          if(ierr/=NF_NOERR) then
    4013            write(*,*) NF_STRERROR(ierr)
    4014            stop 'height'
    4015          endif
    4016 
    4017        ierr=NF_INQ_VARID(nid,"pf",var3didin(11))
    4018          if(ierr/=NF_NOERR) then
    4019            write(*,*) NF_STRERROR(ierr)
    4020            stop 'pf'
    4021          endif
    4022 
    4023       ierr=NF_INQ_VARID(nid,"theta",var3didin(12))
    4024          if(ierr/=NF_NOERR) then
    4025            write(*,*) NF_STRERROR(ierr)
    4026            stop 'theta'
    4027          endif
    4028 
    4029       ierr=NF_INQ_VARID(nid,"qv",var3didin(13))
    4030          if(ierr/=NF_NOERR) then
    4031            write(*,*) NF_STRERROR(ierr)
    4032            stop 'qv'
    4033          endif
    4034 
    4035       ierr=NF_INQ_VARID(nid,"u",var3didin(14))
    4036          if(ierr/=NF_NOERR) then
    4037            write(*,*) NF_STRERROR(ierr)
    4038            stop 'u'
    4039          endif
    4040 
    4041       ierr=NF_INQ_VARID(nid,"v",var3didin(15))
    4042          if(ierr/=NF_NOERR) then
    4043            write(*,*) NF_STRERROR(ierr)
    4044            stop 'v'
    4045          endif
    4046 
    4047       ierr=NF_INQ_VARID(nid,"o3mmr",var3didin(16))
    4048          if(ierr/=NF_NOERR) then
    4049            write(*,*) NF_STRERROR(ierr)
    4050            stop 'o3'
    4051          endif
    4052 
    4053       ierr=NF_INQ_VARID(nid,"shf",var3didin(2))
    4054          if(ierr/=NF_NOERR) then
    4055            write(*,*) NF_STRERROR(ierr)
    4056            stop 'shf'
    4057          endif
    4058 
    4059       ierr=NF_INQ_VARID(nid,"lhf",var3didin(3))
    4060          if(ierr/=NF_NOERR) then
    4061            write(*,*) NF_STRERROR(ierr)
    4062            stop 'lhf'
    4063          endif
    4064      
    4065       ierr=NF_INQ_VARID(nid,"lwup",var3didin(4))
    4066          if(ierr/=NF_NOERR) then
    4067            write(*,*) NF_STRERROR(ierr)
    4068            stop 'lwup'
    4069          endif
    4070 
    4071       ierr=NF_INQ_VARID(nid,"swup",var3didin(5))
    4072          if(ierr/=NF_NOERR) then
    4073            write(*,*) NF_STRERROR(ierr)
    4074            stop 'dqtdx'
    4075          endif
    4076 
    4077       ierr=NF_INQ_VARID(nid,"Tg",var3didin(6))
    4078          if(ierr/=NF_NOERR) then
    4079            write(*,*) NF_STRERROR(ierr)
    4080            stop 'Tg'
    4081       endif
    4082 
    4083       ierr=NF_INQ_VARID(nid,"ustar",var3didin(7))
    4084          if(ierr/=NF_NOERR) then
    4085            write(*,*) NF_STRERROR(ierr)
    4086            stop 'ustar'
    4087       endif
    4088 
    4089       ierr=NF_INQ_VARID(nid,"psurf",var3didin(8))
    4090          if(ierr/=NF_NOERR) then
    4091            write(*,*) NF_STRERROR(ierr)
    4092            stop 'psurf'
    4093       endif
    4094 
    4095       ierr=NF_INQ_VARID(nid,"Ug",var3didin(9))
    4096          if(ierr/=NF_NOERR) then
    4097            write(*,*) NF_STRERROR(ierr)
    4098            stop 'Ug'
    4099       endif
    4100 
    4101       ierr=NF_INQ_VARID(nid,"Vg",var3didin(10))
    4102          if(ierr/=NF_NOERR) then
    4103            write(*,*) NF_STRERROR(ierr)
    4104            stop 'Vg'
    4105       endif
    4106 
    4107       ierr=NF_INQ_VARID(nid,"hadvT",var3didin(17))
    4108          if(ierr/=NF_NOERR) then
    4109            write(*,*) NF_STRERROR(ierr)
    4110            stop 'hadvT'
    4111       endif
    4112 
    4113       ierr=NF_INQ_VARID(nid,"hadvq",var3didin(18))
    4114          if(ierr/=NF_NOERR) then
    4115            write(*,*) NF_STRERROR(ierr)
    4116            stop 'hadvq'
    4117       endif
    4118 
    4119       ierr=NF_INQ_VARID(nid,"hadvu",var3didin(19))
    4120          if(ierr/=NF_NOERR) then
    4121            write(*,*) NF_STRERROR(ierr)
    4122            stop 'hadvu'
    4123       endif
    4124 
    4125       ierr=NF_INQ_VARID(nid,"hadvv",var3didin(20))
    4126          if(ierr/=NF_NOERR) then
    4127            write(*,*) NF_STRERROR(ierr)
    4128            stop 'hadvv'
    4129       endif
    4130 
    4131       ierr=NF_INQ_VARID(nid,"w",var3didin(21))
    4132          if(ierr/=NF_NOERR) then
    4133            write(*,*) NF_STRERROR(ierr)
    4134            stop 'w'
    4135       endif
    4136 
    4137       ierr=NF_INQ_VARID(nid,"omega",var3didin(22))
    4138          if(ierr/=NF_NOERR) then
    4139            write(*,*) NF_STRERROR(ierr)
    4140            stop 'omega'
    4141       endif
    4142 !dimensions lecture
    4143 !      call catchaxis(nid,ntime,nlevel,time,z,ierr)
    4144  
    4145 #ifdef NC_DOUBLE
    4146          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
    4147 #else
    4148          ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
    4149 #endif
    4150          if(ierr/=NF_NOERR) then
    4151             write(*,*) NF_STRERROR(ierr)
    4152             stop "getvarup"
    4153          endif
    4154 !          write(*,*)'lecture zz ok',zz
    4155  
    4156 #ifdef NC_DOUBLE
    4157          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),pres)
    4158 #else
    4159          ierr = NF_GET_VAR_REAL(nid,var3didin(11),pres)
    4160 #endif
    4161          if(ierr/=NF_NOERR) then
    4162             write(*,*) NF_STRERROR(ierr)
    4163             stop "getvarup"
    4164          endif
    4165 !          write(*,*)'lecture pres ok',pres
    4166 
    4167 #ifdef NC_DOUBLE
    4168          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),th)
    4169 #else
    4170          ierr = NF_GET_VAR_REAL(nid,var3didin(12),th)
    4171 #endif
    4172          if(ierr/=NF_NOERR) then
    4173             write(*,*) NF_STRERROR(ierr)
    4174             stop "getvarup"
    4175          endif
    4176 !          write(*,*)'lecture th ok',th
    4177            do k=1,nlevel
    4178              t(k)=th(k)*(pres(k)/pzero)**rkappa
    4179            enddo
    4180 
    4181 #ifdef NC_DOUBLE
    4182          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),qv)
    4183 #else
    4184          ierr = NF_GET_VAR_REAL(nid,var3didin(13),qv)
    4185 #endif
    4186          if(ierr/=NF_NOERR) then
    4187             write(*,*) NF_STRERROR(ierr)
    4188             stop "getvarup"
    4189          endif
    4190 !          write(*,*)'lecture qv ok',qv
    4191  
    4192 #ifdef NC_DOUBLE
    4193          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),u)
    4194 #else
    4195          ierr = NF_GET_VAR_REAL(nid,var3didin(14),u)
    4196 #endif
    4197          if(ierr/=NF_NOERR) then
    4198             write(*,*) NF_STRERROR(ierr)
    4199             stop "getvarup"
    4200          endif
    4201 !          write(*,*)'lecture u ok',u
    4202 
    4203 #ifdef NC_DOUBLE
    4204          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),v)
    4205 #else
    4206          ierr = NF_GET_VAR_REAL(nid,var3didin(15),v)
    4207 #endif
    4208          if(ierr/=NF_NOERR) then
    4209             write(*,*) NF_STRERROR(ierr)
    4210             stop "getvarup"
    4211          endif
    4212 !          write(*,*)'lecture v ok',v
    4213 
    4214 #ifdef NC_DOUBLE
    4215          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),o3)
    4216 #else
    4217          ierr = NF_GET_VAR_REAL(nid,var3didin(16),o3)
    4218 #endif
    4219          if(ierr/=NF_NOERR) then
    4220             write(*,*) NF_STRERROR(ierr)
    4221             stop "getvarup"
    4222          endif
    4223 !          write(*,*)'lecture o3 ok',o3
    4224 
    4225 #ifdef NC_DOUBLE
    4226          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),shf)
    4227 #else
    4228          ierr = NF_GET_VAR_REAL(nid,var3didin(2),shf)
    4229 #endif
    4230          if(ierr/=NF_NOERR) then
    4231             write(*,*) NF_STRERROR(ierr)
    4232             stop "getvarup"
    4233          endif
    4234 !          write(*,*)'lecture shf ok',shf
    4235 
    4236 #ifdef NC_DOUBLE
    4237          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),lhf)
    4238 #else
    4239          ierr = NF_GET_VAR_REAL(nid,var3didin(3),lhf)
    4240 #endif
    4241          if(ierr/=NF_NOERR) then
    4242             write(*,*) NF_STRERROR(ierr)
    4243             stop "getvarup"
    4244          endif
    4245 !          write(*,*)'lecture lhf ok',lhf
    4246 
    4247 #ifdef NC_DOUBLE
    4248          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),lwup)
    4249 #else
    4250          ierr = NF_GET_VAR_REAL(nid,var3didin(4),lwup)
    4251 #endif
    4252          if(ierr/=NF_NOERR) then
    4253             write(*,*) NF_STRERROR(ierr)
    4254             stop "getvarup"
    4255          endif
    4256 !          write(*,*)'lecture lwup ok',lwup
    4257 
    4258 #ifdef NC_DOUBLE
    4259          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),swup)
    4260 #else
    4261          ierr = NF_GET_VAR_REAL(nid,var3didin(5),swup)
    4262 #endif
    4263          if(ierr/=NF_NOERR) then
    4264             write(*,*) NF_STRERROR(ierr)
    4265             stop "getvarup"
    4266          endif
    4267 !          write(*,*)'lecture swup ok',swup
    4268 
    4269 #ifdef NC_DOUBLE
    4270          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tg)
    4271 #else
    4272          ierr = NF_GET_VAR_REAL(nid,var3didin(6),tg)
    4273 #endif
    4274          if(ierr/=NF_NOERR) then
    4275             write(*,*) NF_STRERROR(ierr)
    4276             stop "getvarup"
    4277          endif
    4278 !          write(*,*)'lecture tg ok',tg
    4279 
    4280 #ifdef NC_DOUBLE
    4281          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ustar)
    4282 #else
    4283          ierr = NF_GET_VAR_REAL(nid,var3didin(7),ustar)
    4284 #endif
    4285          if(ierr/=NF_NOERR) then
    4286             write(*,*) NF_STRERROR(ierr)
    4287             stop "getvarup"
    4288          endif
    4289 !          write(*,*)'lecture ustar ok',ustar
    4290 
    4291 #ifdef NC_DOUBLE
    4292          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),psurf)
    4293 #else
    4294          ierr = NF_GET_VAR_REAL(nid,var3didin(8),psurf)
    4295 #endif
    4296          if(ierr/=NF_NOERR) then
    4297             write(*,*) NF_STRERROR(ierr)
    4298             stop "getvarup"
    4299          endif
    4300 !          write(*,*)'lecture psurf ok',psurf
    4301 
    4302 #ifdef NC_DOUBLE
    4303          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),ug)
    4304 #else
    4305          ierr = NF_GET_VAR_REAL(nid,var3didin(9),ug)
    4306 #endif
    4307          if(ierr/=NF_NOERR) then
    4308             write(*,*) NF_STRERROR(ierr)
    4309             stop "getvarup"
    4310          endif
    4311 !          write(*,*)'lecture ug ok',ug
    4312 
    4313 #ifdef NC_DOUBLE
    4314          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),vg)
    4315 #else
    4316          ierr = NF_GET_VAR_REAL(nid,var3didin(10),vg)
    4317 #endif
    4318          if(ierr/=NF_NOERR) then
    4319             write(*,*) NF_STRERROR(ierr)
    4320             stop "getvarup"
    4321          endif
    4322 !          write(*,*)'lecture vg ok',vg
    4323 
    4324 #ifdef NC_DOUBLE
    4325          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hadvt)
    4326 #else
    4327          ierr = NF_GET_VAR_REAL(nid,var3didin(17),hadvt)
    4328 #endif
    4329          if(ierr/=NF_NOERR) then
    4330             write(*,*) NF_STRERROR(ierr)
    4331             stop "getvarup"
    4332          endif
    4333 !          write(*,*)'lecture hadvt ok',hadvt
    4334 
    4335 #ifdef NC_DOUBLE
    4336          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),hadvq)
    4337 #else
    4338          ierr = NF_GET_VAR_REAL(nid,var3didin(18),hadvq)
    4339 #endif
    4340          if(ierr/=NF_NOERR) then
    4341             write(*,*) NF_STRERROR(ierr)
    4342             stop "getvarup"
    4343          endif
    4344 !          write(*,*)'lecture hadvq ok',hadvq
    4345 
    4346 #ifdef NC_DOUBLE
    4347          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),hadvu)
    4348 #else
    4349          ierr = NF_GET_VAR_REAL(nid,var3didin(19),hadvu)
    4350 #endif
    4351          if(ierr/=NF_NOERR) then
    4352             write(*,*) NF_STRERROR(ierr)
    4353             stop "getvarup"
    4354          endif
    4355 !          write(*,*)'lecture hadvu ok',hadvu
    4356 
    4357 #ifdef NC_DOUBLE
    4358          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),hadvv)
    4359 #else
    4360          ierr = NF_GET_VAR_REAL(nid,var3didin(20),hadvv)
    4361 #endif
    4362          if(ierr/=NF_NOERR) then
    4363             write(*,*) NF_STRERROR(ierr)
    4364             stop "getvarup"
    4365          endif
    4366 !          write(*,*)'lecture hadvv ok',hadvv
    4367 
    4368 #ifdef NC_DOUBLE
    4369          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),w)
    4370 #else
    4371          ierr = NF_GET_VAR_REAL(nid,var3didin(21),w)
    4372 #endif
    4373          if(ierr/=NF_NOERR) then
    4374             write(*,*) NF_STRERROR(ierr)
    4375             stop "getvarup"
    4376          endif
    4377 !          write(*,*)'lecture w ok',w
    4378 
    4379 #ifdef NC_DOUBLE
    4380          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),omega)
    4381 #else
    4382          ierr = NF_GET_VAR_REAL(nid,var3didin(22),omega)
    4383 #endif
    4384          if(ierr/=NF_NOERR) then
    4385             write(*,*) NF_STRERROR(ierr)
    4386             stop "getvarup"
    4387          endif
    4388 !          write(*,*)'lecture omega ok',omega
    4389 
    4390          return
    4391          end subroutine read_dice
    4392 !=====================================================================
    4393       subroutine read_gabls4(fich_gabls4,nlevel,ntime,nsol                    &
    4394      &     ,zz,depth_sn,ug,vg,pf,th,t,qv,u,v,hadvt,hadvq,tg,tsnow,snow_dens)
    4395 
    4396 !program reading initial profils and forcings of the Gabls4 case study
    4397 
    4398 
    4399       implicit none
    4400 
    4401 #include "netcdf.inc"
    4402 
    4403       integer ntime,nlevel,nsol
    4404       integer l,k
    4405       character*80 :: fich_gabls4
    4406       real*8 time(ntime)
    4407 
    4408 !  ATTENTION: visiblement quand on lit gabls4_driver.nc on recupere les donnees
    4409 ! dans un ordre inverse par rapport a la convention LMDZ
    4410 ! ==> il faut tout inverser  (MPL 20141024)
    4411 ! les variables indexees "_i" sont celles qui sont lues dans gabls4_driver.nc
    4412       real*8 zz_i(nlevel),th_i(nlevel),pf_i(nlevel),t_i(nlevel)
    4413       real*8 qv_i(nlevel),u_i(nlevel),v_i(nlevel),ug_i(nlevel,ntime),vg_i(nlevel,ntime)
    4414       real*8 hadvt_i(nlevel,ntime),hadvq_i(nlevel,ntime)
    4415 
    4416       real*8 zz(nlevel),th(nlevel),pf(nlevel),t(nlevel)
    4417       real*8 qv(nlevel),u(nlevel),v(nlevel),ug(nlevel,ntime),vg(nlevel,ntime)
    4418       real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime)
    4419 
    4420       real*8 depth_sn(nsol),tsnow(nsol),snow_dens(nsol)
    4421       real*8 tg(ntime)
    4422       integer nid, ierr
    4423       integer nbvar3d
    4424       parameter(nbvar3d=30)
    4425       integer var3didin(nbvar3d)
    4426 
    4427       ierr = NF_OPEN(fich_gabls4,NF_NOWRITE,nid)
    4428       if (ierr.NE.NF_NOERR) then
    4429          write(*,*) 'ERROR: Pb opening forcings nc file '
    4430          write(*,*) NF_STRERROR(ierr)
    4431          stop ""
    4432       endif
    4433 
    4434 
    4435        ierr=NF_INQ_VARID(nid,"height",var3didin(1))
    4436          if(ierr/=NF_NOERR) then
    4437            write(*,*) NF_STRERROR(ierr)
    4438            stop 'height'
    4439          endif
    4440 
    4441       ierr=NF_INQ_VARID(nid,"depth_sn",var3didin(2))
    4442          if(ierr/=NF_NOERR) then
    4443            write(*,*) NF_STRERROR(ierr)
    4444            stop 'depth_sn'
    4445       endif
    4446 
    4447       ierr=NF_INQ_VARID(nid,"Ug",var3didin(3))
    4448          if(ierr/=NF_NOERR) then
    4449            write(*,*) NF_STRERROR(ierr)
    4450            stop 'Ug'
    4451       endif
    4452 
    4453       ierr=NF_INQ_VARID(nid,"Vg",var3didin(4))
    4454          if(ierr/=NF_NOERR) then
    4455            write(*,*) NF_STRERROR(ierr)
    4456            stop 'Vg'
    4457       endif
    4458        ierr=NF_INQ_VARID(nid,"pf",var3didin(5))
    4459          if(ierr/=NF_NOERR) then
    4460            write(*,*) NF_STRERROR(ierr)
    4461            stop 'pf'
    4462          endif
    4463 
    4464       ierr=NF_INQ_VARID(nid,"theta",var3didin(6))
    4465          if(ierr/=NF_NOERR) then
    4466            write(*,*) NF_STRERROR(ierr)
    4467            stop 'theta'
    4468          endif
    4469 
    4470       ierr=NF_INQ_VARID(nid,"tempe",var3didin(7))
    4471          if(ierr/=NF_NOERR) then
    4472            write(*,*) NF_STRERROR(ierr)
    4473            stop 'tempe'
    4474          endif
    4475 
    4476       ierr=NF_INQ_VARID(nid,"qv",var3didin(8))
    4477          if(ierr/=NF_NOERR) then
    4478            write(*,*) NF_STRERROR(ierr)
    4479            stop 'qv'
    4480          endif
    4481 
    4482       ierr=NF_INQ_VARID(nid,"u",var3didin(9))
    4483          if(ierr/=NF_NOERR) then
    4484            write(*,*) NF_STRERROR(ierr)
    4485            stop 'u'
    4486          endif
    4487 
    4488       ierr=NF_INQ_VARID(nid,"v",var3didin(10))
    4489          if(ierr/=NF_NOERR) then
    4490            write(*,*) NF_STRERROR(ierr)
    4491            stop 'v'
    4492          endif
    4493 
    4494       ierr=NF_INQ_VARID(nid,"hadvT",var3didin(11))
    4495          if(ierr/=NF_NOERR) then
    4496            write(*,*) NF_STRERROR(ierr)
    4497            stop 'hadvt'
    4498          endif
    4499 
    4500       ierr=NF_INQ_VARID(nid,"hadvQ",var3didin(12))
    4501          if(ierr/=NF_NOERR) then
    4502            write(*,*) NF_STRERROR(ierr)
    4503            stop 'hadvq'
    4504       endif
    4505 
    4506       ierr=NF_INQ_VARID(nid,"Tsnow",var3didin(14))
    4507          if(ierr/=NF_NOERR) then
    4508            write(*,*) NF_STRERROR(ierr)
    4509            stop 'tsnow'
    4510       endif
    4511 
    4512       ierr=NF_INQ_VARID(nid,"snow_density",var3didin(15))
    4513          if(ierr/=NF_NOERR) then
    4514            write(*,*) NF_STRERROR(ierr)
    4515            stop 'snow_density'
    4516       endif
    4517 
    4518       ierr=NF_INQ_VARID(nid,"Tg",var3didin(16))
    4519          if(ierr/=NF_NOERR) then
    4520            write(*,*) NF_STRERROR(ierr)
    4521            stop 'Tg'
    4522       endif
    4523 
    4524 
    4525 !dimensions lecture
    4526 !      call catchaxis(nid,ntime,nlevel,time,z,ierr)
    4527  
    4528 #ifdef NC_DOUBLE
    4529          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz_i)
    4530 #else
    4531          ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz_i)
    4532 #endif
    4533          if(ierr/=NF_NOERR) then
    4534             write(*,*) NF_STRERROR(ierr)
    4535             stop "getvarup"
    4536          endif
    4537  
    4538 #ifdef NC_DOUBLE
    4539          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),depth_sn)
    4540 #else
    4541          ierr = NF_GET_VAR_REAL(nid,var3didin(2),depth_sn)
    4542 #endif
    4543          if(ierr/=NF_NOERR) then
    4544             write(*,*) NF_STRERROR(ierr)
    4545             stop "getvarup"
    4546          endif
    4547  
    4548 #ifdef NC_DOUBLE
    4549          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),ug_i)
    4550 #else
    4551          ierr = NF_GET_VAR_REAL(nid,var3didin(3),ug_i)
    4552 #endif
    4553          if(ierr/=NF_NOERR) then
    4554             write(*,*) NF_STRERROR(ierr)
    4555             stop "getvarup"
    4556          endif
    4557  
    4558 #ifdef NC_DOUBLE
    4559          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),vg_i)
    4560 #else
    4561          ierr = NF_GET_VAR_REAL(nid,var3didin(4),vg_i)
    4562 #endif
    4563          if(ierr/=NF_NOERR) then
    4564             write(*,*) NF_STRERROR(ierr)
    4565             stop "getvarup"
    4566          endif
    4567  
    4568 #ifdef NC_DOUBLE
    4569          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),pf_i)
    4570 #else
    4571          ierr = NF_GET_VAR_REAL(nid,var3didin(5),pf_i)
    4572 #endif
    4573          if(ierr/=NF_NOERR) then
    4574             write(*,*) NF_STRERROR(ierr)
    4575             stop "getvarup"
    4576          endif
    4577 
    4578 #ifdef NC_DOUBLE
    4579          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),th_i)
    4580 #else
    4581          ierr = NF_GET_VAR_REAL(nid,var3didin(6),th_i)
    4582 #endif
    4583          if(ierr/=NF_NOERR) then
    4584             write(*,*) NF_STRERROR(ierr)
    4585             stop "getvarup"
    4586          endif
    4587 
    4588 #ifdef NC_DOUBLE
    4589          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),t_i)
    4590 #else
    4591          ierr = NF_GET_VAR_REAL(nid,var3didin(7),t_i)
    4592 #endif
    4593          if(ierr/=NF_NOERR) then
    4594             write(*,*) NF_STRERROR(ierr)
    4595             stop "getvarup"
    4596          endif
    4597 
    4598 #ifdef NC_DOUBLE
    4599          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),qv_i)
    4600 #else
    4601          ierr = NF_GET_VAR_REAL(nid,var3didin(8),qv_i)
    4602 #endif
    4603          if(ierr/=NF_NOERR) then
    4604             write(*,*) NF_STRERROR(ierr)
    4605             stop "getvarup"
    4606          endif
    4607  
    4608 #ifdef NC_DOUBLE
    4609          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),u_i)
    4610 #else
    4611          ierr = NF_GET_VAR_REAL(nid,var3didin(9),u_i)
    4612 #endif
    4613          if(ierr/=NF_NOERR) then
    4614             write(*,*) NF_STRERROR(ierr)
    4615             stop "getvarup"
    4616          endif
    4617  
    4618 #ifdef NC_DOUBLE
    4619          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),v_i)
    4620 #else
    4621          ierr = NF_GET_VAR_REAL(nid,var3didin(10),v_i)
    4622 #endif
    4623          if(ierr/=NF_NOERR) then
    4624             write(*,*) NF_STRERROR(ierr)
    4625             stop "getvarup"
    4626          endif
    4627  
    4628 #ifdef NC_DOUBLE
    4629          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),hadvt_i)
    4630 #else
    4631          ierr = NF_GET_VAR_REAL(nid,var3didin(11),hadvt_i)
    4632 #endif
    4633          if(ierr/=NF_NOERR) then
    4634             write(*,*) NF_STRERROR(ierr)
    4635             stop "getvarup"
    4636          endif
    4637  
    4638 #ifdef NC_DOUBLE
    4639          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),hadvq_i)
    4640 #else
    4641          ierr = NF_GET_VAR_REAL(nid,var3didin(12),hadvq_i)
    4642 #endif
    4643          if(ierr/=NF_NOERR) then
    4644             write(*,*) NF_STRERROR(ierr)
    4645             stop "getvarup"
    4646          endif
    4647  
    4648 #ifdef NC_DOUBLE
    4649          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),tsnow)
    4650 #else
    4651          ierr = NF_GET_VAR_REAL(nid,var3didin(14),tsnow)
    4652 #endif
    4653          if(ierr/=NF_NOERR) then
    4654             write(*,*) NF_STRERROR(ierr)
    4655             stop "getvarup"
    4656          endif
    4657  
    4658 #ifdef NC_DOUBLE
    4659          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),snow_dens)
    4660 #else
    4661          ierr = NF_GET_VAR_REAL(nid,var3didin(15),snow_dens)
    4662 #endif
    4663          if(ierr/=NF_NOERR) then
    4664             write(*,*) NF_STRERROR(ierr)
    4665             stop "getvarup"
    4666          endif
    4667 
    4668 #ifdef NC_DOUBLE
    4669          ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),tg)
    4670 #else
    4671          ierr = NF_GET_VAR_REAL(nid,var3didin(16),tg)
    4672 #endif
    4673          if(ierr/=NF_NOERR) then
    4674             write(*,*) NF_STRERROR(ierr)
    4675             stop "getvarup"
    4676          endif
    4677 
    4678 ! On remet les variables lues dans le bon ordre des niveaux (MPL 20141024)
    4679          do k=1,nlevel
    4680            zz(k)=zz_i(nlevel+1-k)
    4681            ug(k,:)=ug_i(nlevel+1-k,:)
    4682            vg(k,:)=vg_i(nlevel+1-k,:)
    4683            pf(k)=pf_i(nlevel+1-k)
    4684            print *,'pf=',pf(k)
    4685            th(k)=th_i(nlevel+1-k)
    4686            t(k)=t_i(nlevel+1-k)
    4687            qv(k)=qv_i(nlevel+1-k)
    4688            u(k)=u_i(nlevel+1-k)
    4689            v(k)=v_i(nlevel+1-k)
    4690            hadvt(k,:)=hadvt_i(nlevel+1-k,:)
    4691            hadvq(k,:)=hadvq_i(nlevel+1-k,:)
    4692          enddo
    4693          return
    4694  end subroutine read_gabls4
    4695 !=====================================================================
    4696 
    4697 !     Reads CIRC input files     
    4698 
    4699       SUBROUTINE read_circ(nlev_circ,cf,lwp,iwp,reliq,reice,t,z,p,pm,h2o,o3,sza)
    4700      
    4701       parameter (ncm_1=49180)
    4702 #include "YOMCST.h"
    4703 
    4704       real albsfc(ncm_1), albsfc_w(ncm_1)
    4705       real cf(nlev_circ), icefra(nlev_circ), deice(nlev_circ), &
    4706            reliq(nlev_circ), reice(nlev_circ), lwp(nlev_circ), iwp(nlev_circ)
    4707       real t(nlev_circ+1), z(nlev_circ+1), dz(nlev_circ), p(nlev_circ+1)
    4708       real aer_beta(nlev_circ), waer(nlev_circ), gaer(nlev_circ)
    4709       real pm(nlev_circ), tm(nlev_circ), h2o(nlev_circ), o3(nlev_circ)
    4710       real co2(nlev_circ), n2o(nlev_circ), co(nlev_circ), ch4(nlev_circ), &
    4711            o2(nlev_circ), ccl4(nlev_circ), f11(nlev_circ), f12(nlev_circ)
    4712 !     za= zenital angle
    4713 !     sza= cosinus angle zenital
    4714       real wavn(ncm_1), ssf(ncm_1),za,sza
    4715       integer nlev
    4716 
    4717 
    4718 !     Open the files
    4719 
    4720       open (11, file='Tsfc_sza_nlev_case.txt', status='old')
    4721       open (12, file='level_input_case.txt', status='old')
    4722       open (13, file='layer_input_case.txt', status='old')
    4723       open (14, file='aerosol_input_case.txt', status='old')
    4724       open (15, file='cloud_input_case.txt', status='old')
    4725       open (16, file='sfcalbedo_input_case.txt', status='old')
    4726      
    4727 !     Read scalar information
    4728       do iskip=1,5
    4729          read (11, *)
    4730       enddo
    4731       read (11, '(i8)') nlev
    4732       read (11, '(f10.2)') tsfc
    4733       read (11, '(f10.2)') za
    4734       read (11, '(f10.4)') sw_dn_toa
    4735       sza=cos(za/180.*RPI)
    4736       print *,'nlev,tsfc,sza,sw_dn_toa,RPI',nlev,tsfc,sza,sw_dn_toa,RPI
    4737       close(11)
    4738 
    4739 !     Read level information
    4740       read (12, *)
    4741       do il=1,nlev
    4742          read (12, 302) ilev, z(il), p(il), t(il)
    4743          z(il)=z(il)*1000.    ! z donne en km
    4744          p(il)=p(il)*100.     ! p donne en mb
    4745       enddo
    4746 302   format (i8, f8.3, 2f9.2)
    4747       close(12)
    4748 
    4749 !     Read layer information (midpoint values)
    4750       do iskip=1,3
    4751          read (13, *)
    4752       enddo
    4753       do il=1,nlev-1
    4754          read (13, 303) ilev,pm(il),tm(il),h2o(il),co2(il),o3(il), &
    4755                         n2o(il),co(il),ch4(il),o2(il),ccl4(il), &
    4756                         f11(il),f12(il)
    4757          pm(il)=pm(il)*100.
    4758       enddo
    4759 303   format (i8, 2f9.2, 10(2x,e13.7))     
    4760       close(13)
    4761      
    4762 !     Read aerosol layer information
    4763       do iskip=1,3
    4764          read (14, *)
    4765       enddo
    4766       read (14, '(f10.2)') aer_alpha
    4767       read (14, *)
    4768       read (14, *)
    4769       do il=1,nlev-1
    4770          read (14, 304) ilev, aer_beta(il), waer(il), gaer(il)
    4771       enddo
    4772 304   format (i8, f9.5, 2f8.3)
    4773       close(14)
    4774      
    4775 !     Read cloud information
    4776       do iskip=1,3
    4777          read (15, *)
    4778       enddo
    4779       do il=1,nlev-1
    4780          read (15, 305) ilev, cf(il), lwp(il), iwp(il), reliq(il), reice(il)
    4781          lwp(il)=lwp(il)/1000.          ! lwp donne en g/kg
    4782          iwp(il)=iwp(il)/1000.          ! iwp donne en g/kg
    4783          reliq(il)=reliq(il)/1000000.   ! reliq donne en microns
    4784          reice(il)=reice(il)/1000000.   ! reice donne en microns
    4785       enddo
    4786 305   format (i8, f8.3, 4f9.2)
    4787       close(15)
    4788 
    4789 !     Read surface albedo (weighted & unweighted) and spectral solar irradiance
    4790       do iskip=1,6
    4791          read (16, *)
    4792       enddo
    4793       do icm_1=1,ncm_1
    4794          read (16, 306) wavn(icm_1), albsfc(icm_1), albsfc_w(icm_1), ssf(icm_1)
    4795       enddo
    4796 306   format(f10.1, 2f12.5, f14.8)
    4797       close(16)
    4798  
    4799       return
    4800       end subroutine read_circ
    4801 !=====================================================================
    4802 !     Reads RTMIP input files     
    4803 
    4804       SUBROUTINE read_rtmip(nlev_rtmip,play,plev,t,h2o,o3)
    4805      
    4806 #include "YOMCST.h"
    4807 
    4808       real t(nlev_rtmip), pt(nlev_rtmip),pb(nlev_rtmip),h2o(nlev_rtmip), o3(nlev_rtmip)
    4809       real temp(nlev_rtmip), play(nlev_rtmip),ovap(nlev_rtmip), oz(nlev_rtmip),plev(nlev_rtmip+1)
    4810       integer nlev
    4811 
    4812 
    4813 !     Open the files
    4814 
    4815       open (11, file='low_resolution_profile.txt', status='old')
    4816      
    4817 !     Read level information
    4818       read (11, *)
    4819       do il=1,nlev_rtmip
    4820          read (11, 302) pt(il), pb(il), t(il),h2o(il),o3(il)
    4821       enddo
    4822       do il=1,nlev_rtmip
    4823          play(il)=pt(nlev_rtmip-il+1)*100.     ! p donne en mb
    4824          temp(il)=t(nlev_rtmip-il+1)
    4825          ovap(il)=h2o(nlev_rtmip-il+1)
    4826          oz(il)=o3(nlev_rtmip-il+1)
    4827       enddo
    4828       do il=1,39
    4829          plev(il)=play(il)+(play(il+1)-play(il))/2.
    4830          print *,'il p t ovap oz=',il,plev(il),temp(il),ovap(il),oz(il)
    4831       enddo
    4832       plev(41)=101300.
    4833 302   format (e16.10,3x,e16.10,3x,e16.10,3x,e12.6,3x,e12.6)
    4834       close(12)
    4835  
    4836       return
    4837       end subroutine read_rtmip
    4838 !=====================================================================
    48391473
    48401474!  Subroutines for nudging
    … …  
    51251759       real frac,frac1,frac2,fact
    51261760 
    5127        do l = 1, llm
    5128        print *,'debut interp2, play=',l,play(l)
    5129        enddo
     1761!       do l = 1, llm
     1762!       print *,'debut interp2, play=',l,play(l)
     1763!       enddo
    51301764!      do l = 1, nlev_cas
    51311765!      print *,'debut interp2, plev_prof_cas=',l,play(l),plev_prof_cas(l)
    … …  
    51371771 
    51381772        mxcalc=l
    5139         print *,'debut interp2, mxcalc=',mxcalc
     1773!        print *,'debut interp2, mxcalc=',mxcalc
    51401774         k1=0
    51411775         k2=0

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_decl_cases.h

    r3223 r3605  
    3434        real w_mod(llm), t_mod(llm),q_mod(llm)
    3535        real u_mod(llm),v_mod(llm), ht_mod(llm),vt_mod(llm),ug_mod(llm),vg_mod(llm)
     36        real temp_nudg_mod(llm),qv_nudg_mod(llm),u_nudg_mod(llm),v_nudg_mod(llm)
    3637        real hq_mod(llm),vq_mod(llm),qv_mod(llm),ql_mod(llm),qt_mod(llm)
    3738        real th_mod(llm)
    … …  
    9596!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    9697!Declarations specifiques au cas GABLS4   (MPL 20141023)
    97         character*80 :: fich_gabls4
    98         integer nlev_gabls4, nt_gabls4, nsol_gabls4
    99         parameter (nlev_gabls4=90, nt_gabls4=37, nsol_gabls4=19) 
    100         integer year_ini_gabls4, day_ini_gabls4, mth_ini_gabls4
    101         real heure_ini_gabls4
    102         real day_ju_ini_gabls4   ! Julian day of gabls4 first day
    103         parameter (year_ini_gabls4=2009)
    104         parameter (mth_ini_gabls4=12)
    105         parameter (day_ini_gabls4=11)  ! 11 = 11 decembre 2009
    106         parameter (heure_ini_gabls4=0.) !0UTC en secondes
    107         real dt_gabls4
    108         parameter (dt_gabls4=3600.) ! 1 forcage ttes les heures
    109 
     98!FHADETRUIRE
     99!       character*80 :: fich_gabls4
     100!       integer nlev_gabls4, nt_gabls4, nsol_gabls4
     101!       parameter (nlev_gabls4=90, nt_gabls4=37, nsol_gabls4=19) 
     102!       integer year_ini_gabls4, day_ini_gabls4, mth_ini_gabls4
     103!       real heure_ini_gabls4
     104!       real day_ju_ini_gabls4   ! Julian day of gabls4 first day
     105!       parameter (year_ini_gabls4=2009)
     106!       parameter (mth_ini_gabls4=12)
     107!       parameter (day_ini_gabls4=11)  ! 11 = 11 decembre 2009
     108!       parameter (heure_ini_gabls4=0.) !0UTC en secondes
     109!       real dt_gabls4
     110!       parameter (dt_gabls4=3600.) ! 1 forcage ttes les heures
     111!
    110112!profils initiaux:
    111         real plev_gabls4(nlev_gabls4)
    112         real zz_gabls4(nlev_gabls4)
    113         real th_gabls4(nlev_gabls4),t_gabls4(nlev_gabls4),qv_gabls4(nlev_gabls4)
    114         real u_gabls4(nlev_gabls4), v_gabls4(nlev_gabls4)
    115         real depth_sn_gabls4(nsol_gabls4),tsnow_gabls4(nsol_gabls4),snow_dens_gabls4(nsol_gabls4)
    116         real t_gabi(nlev_gabls4),qv_gabi(nlev_gabls4)
    117         real u_gabi(nlev_gabls4), v_gabi(nlev_gabls4),ug_gabi(nlev_gabls4), vg_gabi(nlev_gabls4)
    118         real ht_gabi(nlev_gabls4),hq_gabi(nlev_gabls4),poub(nlev_gabls4)
    119         
     113!       real plev_gabls4(nlev_gabls4)
     114!       real zz_gabls4(nlev_gabls4)
     115!       real th_gabls4(nlev_gabls4),t_gabls4(nlev_gabls4),qv_gabls4(nlev_gabls4)
     116!       real u_gabls4(nlev_gabls4), v_gabls4(nlev_gabls4)
     117!       real depth_sn_gabls4(nsol_gabls4),tsnow_gabls4(nsol_gabls4),snow_dens_gabls4(nsol_gabls4)
     118!       real t_gabi(nlev_gabls4),qv_gabi(nlev_gabls4)
     119!       real u_gabi(nlev_gabls4), v_gabi(nlev_gabls4),ug_gabi(nlev_gabls4), vg_gabi(nlev_gabls4)
     120!       real ht_gabi(nlev_gabls4),hq_gabi(nlev_gabls4),poub(nlev_gabls4)
     121!       
    120122!forcings
    121         real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4)
    122         real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4)
    123         real tg_gabls4(nt_gabls4)
    124         real ht_profg(nlev_gabls4),hq_profg(nlev_gabls4)
    125         real ug_profg(nlev_gabls4),vg_profg(nlev_gabls4)
    126         real tg_profg
    127          
     123! Lignes a detruire ...
     124!       real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4)
     125!       real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4)
     126!       real tg_gabls4(nt_gabls4)
     127!       real ht_profg(nlev_gabls4),hq_profg(nlev_gabls4)
     128!       real ug_profg(nlev_gabls4),vg_profg(nlev_gabls4)
     129!       real tg_profg
     130!       
    128131!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    129132
    … …  
    281284        real qv_mod_cas(llm),ql_mod_cas(llm),qi_mod_cas(llm)
    282285        real ug_mod_cas(llm),vg_mod_cas(llm)
     286        real temp_nudg_mod_cas(llm),qv_nudg_mod_cas(llm),v_nudg_mod_cas(llm),u_nudg_mod_cas(llm)
    283287        real u_mod_cas(llm),v_mod_cas(llm)
    284288        real omega_mod_cas(llm)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_interp_cases.h

    r2920 r3605  
    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
    171
    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
     2         print*,'FORCING CASE forcing_case2'
     3!       print*,                                                             &
     4!    & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=',     &
     5!    &    daytime,day1,(daytime-day1)*86400.,                               &
     6!    &    (daytime-day1)*86400/pdt_cas
    567
    578! 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 
    656         print*,                                                             &
    657      & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=',     &
    658      &    daytime,day1,(daytime-day1)*86400.,                               &
    659      &    (daytime-day1)*86400/pdt_cas
    660 
    661 ! 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) 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                                                               &
    83512     &       ,ts_cas,ps_cas,plev_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,ql_cas,qi_cas      &
    836      &       ,u_cas,v_cas,ug_cas,vg_cas,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas             &
     13     &       ,u_cas,v_cas,ug_cas,vg_cas                                                     &
     14     &       ,temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas                               &
     15     &       ,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas                                       &
    83716     &       ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas                           &
    83817     &       ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,lat_cas,sens_cas,ustar_cas       &
    83918     &       ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas                                           &
    84019!
    841      &       ,ts_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas  &
     20     &       ,ts_prof_cas,ps_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas  &
    84221     &       ,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas                              &
    843      &       ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas    &
     22     &       ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas                                 &
     23     &       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas           &
     24     &       ,vitw_prof_cas,omega_prof_cas                                                  &
    84425     &       ,du_prof_cas,hu_prof_cas,vu_prof_cas                                           &
    84526     &       ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas       &
    … …  
    85334
    85435! vertical interpolation:
    855       CALL interp2_case_vertical(play,nlev_cas,plev_prof_cas                                              &
    856      &         ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas                                          &
     36      CALL interp2_case_vertical_std(play,nlev_cas,plev_prof_cas                                              &
     37     &         ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas                                       &
    85738     &         ,qv_prof_cas,ql_prof_cas,qi_prof_cas,u_prof_cas,v_prof_cas                                 &
    858      &         ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas                                      &
     39     &         ,ug_prof_cas,vg_prof_cas                                                                   &
     40     &         ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas                       &
     41     &         ,vitw_prof_cas,omega_prof_cas                                      &
    85942     &         ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas                   &
    86043     &         ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas    &
    … …  
    86245!
    86346     &         ,t_mod_cas,theta_mod_cas,thv_mod_cas,thl_mod_cas,qv_mod_cas,ql_mod_cas,qi_mod_cas          &
    864      &         ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas,omega_mod_cas                         &
     47     &         ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas                                                 &
     48     &         ,temp_nudg_mod_cas,qv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas                           &
     49     &         ,w_mod_cas,omega_mod_cas                                                                   &
    86550     &         ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas                         &
    86651     &         ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas           &
    … …  
    88469      d_u_dyn_z(:)=0.
    88570      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
     71      if (1==0) then
     72         DO l=2,llm-1
     73          d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1))
     74          d_th_z(l)=(teta(l+1)-teta(l-1))/(play(l+1)-play(l-1))
     75          d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1))
     76          d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1))
     77          d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1))
     78         ENDDO
     79      else
     80         DO l=2,llm-1
     81            IF (omega(l)>0.) THEN
     82             d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l))
     83             d_th_z(l)=(teta(l+1)-teta(l))/(play(l+1)-play(l))
     84             d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l))
     85             d_u_z(l)=(u(l+1)-u(l))/(play(l+1)-play(l))
     86             d_v_z(l)=(v(l+1)-v(l))/(play(l+1)-play(l))
     87            ELSE
     88             d_t_z(l)=(temp(l-1)-temp(l))/(play(l-1)-play(l))
     89             d_th_z(l)=(teta(l-1)-teta(l))/(play(l-1)-play(l))
     90             d_q_z(l)=(q(l-1,1)-q(l,1))/(play(l-1)-play(l))
     91             d_u_z(l)=(u(l-1)-u(l))/(play(l-1)-play(l))
     92             d_v_z(l)=(v(l-1)-v(l))/(play(l-1)-play(l))
     93            ENDIF
     94         ENDDO
     95      endif
     96      d_t_z(1)=d_t_z(2)
    89397      d_t_z(1)=d_t_z(2)
    89498      d_th_z(1)=d_th_z(2)
    … …  
    902106      d_v_z(llm)=d_v_z(llm-1)
    903107
     108! TRAVAIL : PRENDRE DES NOTATIONS COHERENTES POUR W
     109      do l = 1, llm
     110! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309)
     111       omega(l) = -w_mod_cas(l)*play(l)*rg/(rd*temp(l))
     112      enddo
     113
    904114!Calcul de l advection verticale
    905115! 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(:)
     116      d_t_dyn_z(:)=omega(:)*d_t_z(:)
     117      d_th_dyn_z(:)=omega(:)*d_th_z(:)
     118      d_q_dyn_z(:)=omega(:)*d_q_z(:)
     119      d_u_dyn_z(:)=omega(:)*d_u_z(:)
     120      d_v_dyn_z(:)=omega(:)*d_v_z(:)
    911121
    912122!geostrophic wind
    … …  
    917127        enddo
    918128      endif
    919 !wind nudging
    920       if (nudging_u.gt.0.) then
    921         do l=1,llm
    922            u(l)=u(l)+timestep*(u_mod_cas(l)-u(l))/(nudge_u)
    923         enddo
    924 !     else
    925 !       do l=1,llm
    926 !          u(l) = u_mod_cas(l)
    927 !       enddo
    928       endif
    929 
    930       if (nudging_v.gt.0.) then
    931         do l=1,llm
    932            v(l)=v(l)+timestep*(v_mod_cas(l)-v(l))/(nudge_v)
    933         enddo
    934 !     else
    935 !       do l=1,llm
    936 !          v(l) = v_mod_cas(l)
    937 !       enddo
    938       endif
    939 
    940       if (nudging_w.gt.0.) then
    941         do l=1,llm
    942            w(l)=w(l)+timestep*(w_mod_cas(l)-w(l))/(nudge_w)
    943         enddo
    944  !    else
    945  !      do l=1,llm
    946  !         w(l) = w_mod_cas(l)
    947  !      enddo
    948       endif
    949 
    950 !nudging of q and temp
    951       if (nudging_t.gt.0.) then
    952         do l=1,llm
    953            temp(l)=temp(l)+timestep*(t_mod_cas(l)-temp(l))/(nudge_t)
    954         enddo
    955       endif
    956       if (nudging_q.gt.0.) then
    957         do l=1,llm
    958            q(l,1)=q(l,1)+timestep*(q_mod_cas(l)-q(l,1))/(nudge_q)
    959         enddo
    960       endif
    961129
    962130      do l = 1, llm
     131
     132!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    963133! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309)
     134       !!! omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
    964135       omega(l) = omega_mod_cas(l)
    965        omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
    966        alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l)
     136       omega2(l)= omega_mod_cas(l)/rg*airefi ! flxmass_w calcule comme ds physiq
    967137
    968 !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
     138! On effectue la somme du forcage total et de la decomposition
     139! horizontal/vertical en supposant que soit l'un soit l'autre
     140! sont remplis mais jamais les deux
    974141
    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
     142       d_t_adv(l) = dt_mod_cas(l)+ht_mod_cas(l)+vt_mod_cas(l)
     143       d_q_adv(l,1) = dq_mod_cas(l)+hq_mod_cas(l)+vq_mod_cas(l)
     144       d_q_adv(l,2) = 0.0
     145       d_u_adv(l) = du_mod_cas(l)+hu_mod_cas(l)+vu_mod_cas(l)
     146       d_v_adv(l) = dv_mod_cas(l)+hv_mod_cas(l)+vv_mod_cas(l)
    980147
    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)
     148!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     149!! CONSERVE EN ATTENDANT QUE LE CAS EN QUESTION FONCTIONNE EN STD !!
     150!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     151!if (forc_w==1) then
     152!          d_q_adv(l,1)=d_q_adv(l,1)-d_q_dyn_z(l)
     153!          d_t_adv(l)=d_t_adv(l)-d_t_dyn_z(l)
     154!          d_v_adv(l)=d_v_adv(l)-d_v_dyn_z(l)
     155!          d_u_adv(l)=d_u_adv(l)-d_u_dyn_z(l)
    997156!       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)
    1005         endif
     157!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1006158         
    1007159        if (trad.eq.1) then
    … …  
    1025177       print *,'ust=',ust
    1026178      ENDIF
    1027       endif ! forcing_case2
    1028 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1029 

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_nudge_sandu_astex.h

    r3223 r3605  
    3333
    3434
     35        print*,'OLDLMDZ1D IOPH'
     36      CALL iophys_ecrit('relax_thl',klev,'relax_thl','m/s',relax_thl)
     37      CALL iophys_ecrit('d_t_adv',klev,'d_t_adv','m/s',d_t_adv)
     38      CALL iophys_ecrit('temp',klev,'temp','m/s',temp)
     39      CALL iophys_ecrit('q',klev,'q','m/s',q(:,1))
     40      CALL iophys_ecrit('relax_q',klev,'relax_q','m/s',relax_q(:,1))
     41      CALL iophys_ecrit('d_q_adv',klev,'d_q_adv','m/s',d_q_adv(:,1))
     42

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_read_forc_cases.h

    r2920 r3605  
    1111      nq2=0
    1212
    13       if (forcing_les .or. forcing_radconv                                      &
    14      &    .or. forcing_GCSSold .or. forcing_fire) then
     13      print*,'FORCING ,forcing_SCM',forcing_SCM
     14      if (forcing_SCM) then
    1515
    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'
     16         write(*,*),'avant call read_SCM'
     17         call read_SCM_cas
     18         write(*,*) 'Forcing read'
     19         print*,'PS ps_cas',ps_cas
    92220
    92321!Time interpolation for initial conditions using interpolation routine
    92422         write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1   
    925         CALL interp2_case_time(daytime,day1,annee_ref                                       &
     23        CALL interp_case_time_std(daytime,day1,annee_ref                                       &
    92624!    &       ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas                           &
    92725     &       ,nt_cas,nlev_cas                                                               &
    92826     &       ,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             &
     27     &       ,u_cas,v_cas,ug_cas,vg_cas                                                     &
     28     &       ,temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas                               &
     29     &       ,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas                                       &
    93030     &       ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas                           &
    93131     &       ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,lat_cas,sens_cas,ustar_cas       &
    93232     &       ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas                                           &
    93333!
    934      &       ,ts_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas  &
     34     &       ,ts_prof_cas,ps_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas  &
    93535     &       ,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    &
     36     &       ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas                                 &
     37     &       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas           &
     38     &       ,vitw_prof_cas,omega_prof_cas                                                  &
    93739     &       ,du_prof_cas,hu_prof_cas,vu_prof_cas                                           &
    93840     &       ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas       &
    … …  
    94749! vertical interpolation using interpolation routine:
    94850!      write(*,*)'avant interp vert', t_prof
    949       CALL interp2_case_vertical(play,nlev_cas,plev_prof_cas                                              &
     51      CALL interp2_case_vertical_std(play,nlev_cas,plev_prof_cas                                              &
    95052     &         ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas                                          &
    95153     &         ,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                                      &
     54     &         ,ug_prof_cas,vg_prof_cas                                                                   &
     55     &       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas                         &
     56
     57     &         ,vitw_prof_cas,omega_prof_cas                                                              &
    95358     &         ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas                   &
    95459     &         ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas    &
    … …  
    95661!
    95762     &         ,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                         &
     63     &         ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas                                                 &
     64     &         ,temp_nudg_mod_cas,qv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas                           &
     65     &         ,w_mod_cas,omega_mod_cas                                                                   &
    95966     &         ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas                         &
    96067     &         ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas           &
    96168     &         ,dth_mod_cas,hth_mod_cas,vth_mod_cas,mxcalc)
    96269
    963 !       write(*,*) 'Profil initial forcing case interpole',t_mod
    96470
    96571! initial and boundary conditions :
    96672!      tsurf = ts_prof_cas
     73      psurf = ps_prof_cas
    96774      ts_cur = ts_prof_cas
    968       psurf=plev_prof_cas(1)
    969       write(*,*) 'SST initiale: ',tsurf
    97075      do l = 1, llm
    97176       temp(l) = t_mod_cas(l)
    … …  
    98085       omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq
    98186
    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)
     87
     88! On effectue la somme du forcage total et de la decomposition
     89! horizontal/vertical en supposant que soit l'un soit l'autre
     90! sont remplis mais jamais les deux
     91
     92       d_t_adv(l) = dt_mod_cas(l)+ht_mod_cas(l)+vt_mod_cas(l)
     93       d_q_adv(l,1) = dq_mod_cas(l)+hq_mod_cas(l)+vq_mod_cas(l)
    98994       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)
     95       d_u_adv(l) = du_mod_cas(l)+hu_mod_cas(l)+vu_mod_cas(l)
     96       d_v_adv(l) = dv_mod_cas(l)+hv_mod_cas(l)+vv_mod_cas(l)
     97
     98!print*,'d_t_adv ',d_t_adv(1:20)*86400
     99
    995100      enddo     
    996101
    … …  
    1006111       ENDIF
    1007112
    1008       endif !forcing_case2
    1009 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1010 
     113      endif !forcing_SCM

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/compar1d.h

    r2921 r3605  
    4242      integer :: tadv, tadvv, tadvh, qadv, qadvv, qadvh, thadv, thadvv, thadvh, trad
    4343      integer :: forc_omega, forc_u, forc_v, forc_w, forc_geo, forc_ustar
    44       real    :: nudging_u, nudging_v, nudging_w, nudging_t, nudging_q
     44      real    :: nudging_u, nudging_v, nudging_w, nudging_t, nudging_qv
     45      real    :: p_nudging_u, p_nudging_v, p_nudging_w, p_nudging_t, p_nudging_qv
    4546      common/com_par1d/                                                 &
    4647     & nat_surf,tsurf,rugos,rugosh,                                     &
    … …  
    5253     & restart,ok_old_disvert,                                          &
    5354     & tadv, tadvv, tadvh, qadv, qadvv, qadvh, thadv, thadvv, thadvh,   &
    54      & trad, forc_omega, forc_w, forc_geo, forc_ustar,                  &
    55      & nudging_u, nudging_v, nudging_t, nudging_q
     55     & trad, forc_omega, forc_u, forc_v, forc_w, forc_geo, forc_ustar,  &
     56     & nudging_u, nudging_v, nudging_t, nudging_qv, nudging_w,          &
     57     & p_nudging_u, p_nudging_v, p_nudging_t, p_nudging_qv, p_nudging_w
    5658
    5759!$OMP THREADPRIVATE(/com_par1d/)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/lmdz1d.F90

    • Property svn:keywords set to Id
    r3316 r3605  
     1!
     2! $Id$
     3!
    14!#ifdef CPP_1D
    25!#include "../dyn3d/mod_const_mpi.F90"
    … …  
    69
    710
    8       PROGRAM lmdz1d
     11   PROGRAM lmdz1d
    912
    10    USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar
    11    USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, &
    12        clwcon, detr_therm, &
    13        qsol, fevap, z0m, z0h, agesno, &
    14        du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
    15        falb_dir, falb_dif, &
    16        ftsol, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
    17        rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
    18        solsw, t_ancien, q_ancien, u_ancien, v_ancien, wake_cstar, &
    19        wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
    20        wake_deltaq, wake_deltat, wake_s, wake_dens, &
    21        zgam, zmax0, zmea, zpic, zsig, &
    22        zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, &
    23        prlw_ancien, prsw_ancien, prw_ancien
    24  
    25    USE dimphy
    26    USE surface_data, only : type_ocean,ok_veget
    27    USE pbl_surface_mod, only : ftsoil, pbl_surface_init, &
    28                                  pbl_surface_final
    29    USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final
     13   USE ioipsl, only: getin
    3014
    31    USE infotrac ! new
    32    USE control_mod
    33    USE indice_sol_mod
    34    USE phyaqua_mod
    35 !  USE mod_1D_cases_read
    36    USE mod_1D_cases_read2
    37    USE mod_1D_amma_read
    38    USE print_control_mod, ONLY: lunout, prt_level
    39    USE iniphysiq_mod, ONLY: iniphysiq
    40    USE mod_const_mpi, ONLY: comm_lmdz
    41    USE physiq_mod, ONLY: physiq
    42    USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, &
    43                           preff, aps, bps, pseudoalt, scaleheight
    44    USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
    45                         itau_dyn, itau_phy, start_time
     15   INTEGER forcing_type
    4616
    47       implicit none
    48 #include "dimensions.h"
    49 #include "YOMCST.h"
    50 !!#include "control.h"
    51 #include "clesphys.h"
    52 #include "dimsoil.h"
    53 !#include "indicesol.h"
     17   CALL getin('forcing_type',forcing_type)
    5418
    55 #include "compar1d.h"
    56 #include "flux_arp.h"
    57 #include "date_cas.h"
    58 #include "tsoilnudge.h"
    59 #include "fcg_gcssold.h"
    60 !!!#include "fbforcing.h"
    61 #include "compbl.h"
     19   IF (forcing_type==1000) THEN
     20           CALL scm
     21   ELSE
     22           CALL old_lmdz1d
     23   ENDIF
    6224
    63 !=====================================================================
    64 ! DECLARATIONS
    65 !=====================================================================
     25   END
    6626
    67 !---------------------------------------------------------------------
    68 !  Externals
    69 !---------------------------------------------------------------------
    70       external fq_sat
    71       real fq_sat
    72 
    73 !---------------------------------------------------------------------
    74 !  Arguments d' initialisations de la physique (USER DEFINE)
    75 !---------------------------------------------------------------------
    76 
    77       integer, parameter :: ngrid=1
    78       real :: zcufi    = 1.
    79       real :: zcvfi    = 1.
    80 
    81 !-      real :: nat_surf
    82 !-      logical :: ok_flux_surf
    83 !-      real :: fsens
    84 !-      real :: flat
    85 !-      real :: tsurf
    86 !-      real :: rugos
    87 !-      real :: qsol(1:2)
    88 !-      real :: qsurf
    89 !-      real :: psurf
    90 !-      real :: zsurf
    91 !-      real :: albedo
    92 !-
    93 !-      real :: time     = 0.
    94 !-      real :: time_ini
    95 !-      real :: xlat
    96 !-      real :: xlon
    97 !-      real :: wtsurf
    98 !-      real :: wqsurf
    99 !-      real :: restart_runoff
    100 !-      real :: xagesno
    101 !-      real :: qsolinp
    102 !-      real :: zpicinp
    103 !-
    104       real :: fnday
    105       real :: day, daytime
    106       real :: day1
    107       real :: heure
    108       integer :: jour
    109       integer :: mois
    110       integer :: an
    111  
    112 !---------------------------------------------------------------------
    113 !  Declarations related to forcing and initial profiles
    114 !---------------------------------------------------------------------
    115 
    116         integer :: kmax = llm
    117         integer llm700,nq1,nq2
    118         INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
    119         real timestep, frac
    120         real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)
    121         real  uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)
    122         real  ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)
    123         real  dqtdxls(nlev_max),dqtdyls(nlev_max)
    124         real  dqtdtls(nlev_max),thlpcar(nlev_max)
    125         real  qprof(nlev_max,nqmx)
    126 
    127 !        integer :: forcing_type
    128         logical :: forcing_les     = .false.
    129         logical :: forcing_armcu   = .false.
    130         logical :: forcing_rico    = .false.
    131         logical :: forcing_radconv = .false.
    132         logical :: forcing_toga    = .false.
    133         logical :: forcing_twpice  = .false.
    134         logical :: forcing_amma    = .false.
    135         logical :: forcing_dice    = .false.
    136         logical :: forcing_gabls4  = .false.
    137 
    138         logical :: forcing_GCM2SCM = .false.
    139         logical :: forcing_GCSSold = .false.
    140         logical :: forcing_sandu   = .false.
    141         logical :: forcing_astex   = .false.
    142         logical :: forcing_fire    = .false.
    143         logical :: forcing_case    = .false.
    144         logical :: forcing_case2   = .false.
    145         integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
    146 !                                                            (cf read_tsurf1d.F)
    147 
    148 !vertical advection computation
    149 !       real d_t_z(llm), d_q_z(llm)
    150 !       real d_t_dyn_z(llm), dq_dyn_z(llm)
    151 !       real zz(llm)
    152 !       real zfact
    153 
    154 !flag forcings
    155         logical :: nudge_wind=.true.
    156         logical :: nudge_thermo=.false.
    157         logical :: cptadvw=.true.
    158 !=====================================================================
    159 ! DECLARATIONS FOR EACH CASE
    160 !=====================================================================
    161 !
    162 #include "1D_decl_cases.h"
    163 !
    164 !---------------------------------------------------------------------
    165 !  Declarations related to nudging
    166 !---------------------------------------------------------------------
    167      integer :: nudge_max
    168      parameter (nudge_max=9)
    169      integer :: inudge_RHT=1
    170      integer :: inudge_UV=2
    171      logical :: nudge(nudge_max)
    172      real :: t_targ(llm)
    173      real :: rh_targ(llm)
    174      real :: u_targ(llm)
    175      real :: v_targ(llm)
    176 !
    177 !---------------------------------------------------------------------
    178 !  Declarations related to vertical discretization:
    179 !---------------------------------------------------------------------
    180       real :: pzero=1.e5
    181       real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)
    182       real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)
    183 
    184 !---------------------------------------------------------------------
    185 !  Declarations related to variables
    186 !---------------------------------------------------------------------
    187 
    188       real :: phi(llm)
    189       real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
    190       REAL rot(1, llm) ! relative vorticity, in s-1
    191       real :: rlat_rad(1),rlon_rad(1)
    192       real :: omega(llm+1),omega2(llm),rho(llm+1)
    193       real :: ug(llm),vg(llm),fcoriolis
    194       real :: sfdt, cfdt
    195       real :: du_phys(llm),dv_phys(llm),dt_phys(llm)
    196       real :: dt_dyn(llm)
    197       real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)
    198       real :: d_u_nudge(llm),d_v_nudge(llm)
    199       real :: du_adv(llm),dv_adv(llm)
    200       real :: du_age(llm),dv_age(llm)
    201       real :: alpha
    202       real :: ttt
    203 
    204       REAL, ALLOCATABLE, DIMENSION(:,:):: q
    205       REAL, ALLOCATABLE, DIMENSION(:,:):: dq
    206       REAL, ALLOCATABLE, DIMENSION(:,:):: dq_dyn
    207       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
    208       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
    209 !      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
    210 
    211 !---------------------------------------------------------------------
    212 !  Initialization of surface variables
    213 !---------------------------------------------------------------------
    214       real :: run_off_lic_0(1)
    215       real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)
    216       real :: tsoil(1,nsoilmx,nbsrf)
    217 !     real :: agesno(1,nbsrf)
    218 
    219 !---------------------------------------------------------------------
    220 !  Call to phyredem
    221 !---------------------------------------------------------------------
    222       logical :: ok_writedem =.true.
    223       real :: sollw_in = 0.
    224       real :: solsw_in = 0.
    225      
    226 !---------------------------------------------------------------------
    227 !  Call to physiq
    228 !---------------------------------------------------------------------
    229       logical :: firstcall=.true.
    230       logical :: lastcall=.false.
    231       real :: phis(1)    = 0.0
    232       real :: dpsrf(1)
    233 
    234 !---------------------------------------------------------------------
    235 !  Initializations of boundary conditions
    236 !---------------------------------------------------------------------
    237       integer, parameter :: yd = 360
    238       real :: phy_nat (yd) = 0.0 ! 0=ocean libre,1=land,2=glacier,3=banquise
    239       real :: phy_alb (yd)  ! Albedo land only (old value condsurf_jyg=0.3)
    240       real :: phy_sst (yd)  ! SST (will not be used; cf read_tsurf1d.F)
    241       real :: phy_bil (yd) = 1.0 ! Ne sert que pour les slab_ocean
    242       real :: phy_rug (yd) ! Longueur rugosite utilisee sur land only
    243       real :: phy_ice (yd) = 0.0 ! Fraction de glace
    244       real :: phy_fter(yd) = 0.0 ! Fraction de terre
    245       real :: phy_foce(yd) = 0.0 ! Fraction de ocean
    246       real :: phy_fsic(yd) = 0.0 ! Fraction de glace
    247       real :: phy_flic(yd) = 0.0 ! Fraction de glace
    248 
    249 !---------------------------------------------------------------------
    250 !  Fichiers et d'autres variables
    251 !---------------------------------------------------------------------
    252       integer :: k,l,i,it=1,mxcalc
    253       integer :: nsrf
    254       integer jcode
    255       INTEGER read_climoz
    256 !
    257       integer :: it_end ! iteration number of the last call
    258 !Al1
    259       integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
    260       data ecrit_slab_oc/-1/
    261 !
    262 !     if flag_inhib_forcing = 0, tendencies of forcing are added
    263 !                           <> 0, tendencies of forcing are not added
    264       INTEGER :: flag_inhib_forcing = 0
    265 
    266 !=====================================================================
    267 ! INITIALIZATIONS
    268 !=====================================================================
    269       du_phys(:)=0.
    270       dv_phys(:)=0.
    271       dt_phys(:)=0.
    272       dt_dyn(:)=0.
    273       dt_cooling(:)=0.
    274       d_t_adv(:)=0.
    275       d_t_nudge(:)=0.
    276       d_u_nudge(:)=0.
    277       d_v_nudge(:)=0.
    278       du_adv(:)=0.
    279       dv_adv(:)=0.
    280       du_age(:)=0.
    281       dv_age(:)=0.
    282      
    283 ! Initialization of Common turb_forcing
    284        dtime_frcg = 0.
    285        Turb_fcg_gcssold=.false.
    286        hthturb_gcssold = 0.
    287        hqturb_gcssold = 0.
    288 
    289 
    290 
    291 
    292 !---------------------------------------------------------------------
    293 ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
    294 !---------------------------------------------------------------------
    295 !Al1
    296         call conf_unicol
    297 !Al1 moves this gcssold var from common fcg_gcssold to
    298         Turb_fcg_gcssold = xTurb_fcg_gcssold
    299 ! --------------------------------------------------------------------
    300         close(1)
    301 !Al1
    302         write(*,*) 'lmdz1d.def lu => unicol.def'
    303 
    304 ! forcing_type defines the way the SCM is forced:
    305 !forcing_type = 0 ==> forcing_les = .true.
    306 !             initial profiles from file prof.inp.001
    307 !             no forcing by LS convergence ;
    308 !             surface temperature imposed ;
    309 !             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
    310 !forcing_type = 1 ==> forcing_radconv = .true.
    311 !             idem forcing_type = 0, but the imposed radiative cooling
    312 !             is set to 0 (hence, if iflag_radia=0 in physiq.def,
    313 !             then there is no radiative cooling at all)
    314 !forcing_type = 2 ==> forcing_toga = .true.
    315 !             initial profiles from TOGA-COARE IFA files
    316 !             LS convergence and SST imposed from TOGA-COARE IFA files
    317 !forcing_type = 3 ==> forcing_GCM2SCM = .true.
    318 !             initial profiles from the GCM output
    319 !             LS convergence imposed from the GCM output
    320 !forcing_type = 4 ==> forcing_twpice = .true.
    321 !             initial profiles from TWP-ICE cdf file
    322 !             LS convergence, omega and SST imposed from TWP-ICE files
    323 !forcing_type = 5 ==> forcing_rico = .true.
    324 !             initial profiles from RICO files
    325 !             LS convergence imposed from RICO files
    326 !forcing_type = 6 ==> forcing_amma = .true.
    327 !             initial profiles from AMMA nc file
    328 !             LS convergence, omega and surface fluxes imposed from AMMA file 
    329 !forcing_type = 7 ==> forcing_dice = .true.
    330 !             initial profiles and large scale forcings in dice_driver.nc
    331 !             Different stages: soil model alone, atm. model alone
    332 !             then both models coupled
    333 !forcing_type = 8 ==> forcing_gabls4 = .true.
    334 !             initial profiles and large scale forcings in gabls4_driver.nc
    335 !forcing_type >= 100 ==> forcing_case = .true.
    336 !             initial profiles and large scale forcings in cas.nc
    337 !             LS convergence, omega and SST imposed from CINDY-DYNAMO files
    338 !             101=cindynamo
    339 !             102=bomex
    340 !forcing_type >= 100 ==> forcing_case2 = .true.
    341 !             temporary flag while all the 1D cases are not whith the same cas.nc forcing file
    342 !             103=arm_cu2 ie arm_cu with new forcing format
    343 !             104=rico2 ie rico with new forcing format
    344 !forcing_type = 40 ==> forcing_GCSSold = .true.
    345 !             initial profile from GCSS file
    346 !             LS convergence imposed from GCSS file
    347 !forcing_type = 50 ==> forcing_fire = .true.
    348 !             forcing from fire.nc
    349 !forcing_type = 59 ==> forcing_sandu = .true.
    350 !             initial profiles from sanduref file: see prof.inp.001
    351 !             SST varying with time and divergence constante: see ifa_sanduref.txt file
    352 !             Radiation has to be computed interactively
    353 !forcing_type = 60 ==> forcing_astex = .true.
    354 !             initial profiles from file: see prof.inp.001
    355 !             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
    356 !             Radiation has to be computed interactively
    357 !forcing_type = 61 ==> forcing_armcu = .true.
    358 !             initial profiles from file: see prof.inp.001
    359 !             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
    360 !             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
    361 !             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s
    362 !             Radiation to be switched off
    363 !
    364       if (forcing_type <=0) THEN
    365        forcing_les = .true.
    366       elseif (forcing_type .eq.1) THEN
    367        forcing_radconv = .true.
    368       elseif (forcing_type .eq.2) THEN
    369        forcing_toga    = .true.
    370       elseif (forcing_type .eq.3) THEN
    371        forcing_GCM2SCM = .true.
    372       elseif (forcing_type .eq.4) THEN
    373        forcing_twpice = .true.
    374       elseif (forcing_type .eq.5) THEN
    375        forcing_rico = .true.
    376       elseif (forcing_type .eq.6) THEN
    377        forcing_amma = .true.
    378       elseif (forcing_type .eq.7) THEN
    379        forcing_dice = .true.
    380       elseif (forcing_type .eq.8) THEN
    381        forcing_gabls4 = .true.
    382       elseif (forcing_type .eq.101) THEN ! Cindynamo starts 1-10-2011 0h
    383        forcing_case = .true.
    384        year_ini_cas=2011
    385        mth_ini_cas=10
    386        day_deb=1
    387        heure_ini_cas=0.
    388        pdt_cas=3*3600.         ! forcing frequency
    389       elseif (forcing_type .eq.102) THEN ! Bomex starts 24-6-1969 0h
    390        forcing_case = .true.
    391        year_ini_cas=1969
    392        mth_ini_cas=6
    393        day_deb=24
    394        heure_ini_cas=0.
    395        pdt_cas=1800.         ! forcing frequency
    396       elseif (forcing_type .eq.103) THEN ! Arm_cu starts 21-6-1997 11h30
    397        forcing_case2 = .true.
    398        year_ini_cas=1997
    399        mth_ini_cas=6
    400        day_deb=21
    401        heure_ini_cas=11.5
    402        pdt_cas=1800.         ! forcing frequency
    403       elseif (forcing_type .eq.104) THEN ! rico starts 16-12-2004 0h
    404        forcing_case2 = .true.
    405        year_ini_cas=2004
    406        mth_ini_cas=12
    407        day_deb=16
    408        heure_ini_cas=0.
    409        pdt_cas=1800.         ! forcing frequency
    410       elseif (forcing_type .eq.105) THEN ! bomex starts 16-12-2004 0h
    411        forcing_case2 = .true.
    412        year_ini_cas=1969
    413        mth_ini_cas=6
    414        day_deb=24
    415        heure_ini_cas=0.
    416        pdt_cas=1800.         ! forcing frequency
    417       elseif (forcing_type .eq.106) THEN ! ayotte_24SC starts 6-11-1992 0h
    418        forcing_case2 = .true.
    419        year_ini_cas=1992
    420        mth_ini_cas=11
    421        day_deb=6
    422        heure_ini_cas=10.
    423        pdt_cas=86400.        ! forcing frequency
    424       elseif (forcing_type .eq.40) THEN
    425        forcing_GCSSold = .true.
    426       elseif (forcing_type .eq.50) THEN
    427        forcing_fire = .true.
    428       elseif (forcing_type .eq.59) THEN
    429        forcing_sandu   = .true.
    430       elseif (forcing_type .eq.60) THEN
    431        forcing_astex   = .true.
    432       elseif (forcing_type .eq.61) THEN
    433        forcing_armcu = .true.
    434        IF(llm.NE.19.AND.llm.NE.40) stop 'Erreur nombre de niveaux !!'
    435       else
    436        write (*,*) 'ERROR : unknown forcing_type ', forcing_type
    437        stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'
    438       ENDIF
    439       print*,"forcing type=",forcing_type
    440 
    441 ! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time
    442 ! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature
    443 ! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F
    444 ! through the common sst_forcing.
    445 
    446         type_ts_forcing = 0
    447         if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice)                 &
    448      &    type_ts_forcing = 1
    449 !
    450 ! Initialization of the logical switch for nudging
    451      jcode = iflag_nudge
    452      do i = 1,nudge_max
    453        nudge(i) = mod(jcode,10) .ge. 1
    454        jcode = jcode/10
    455      enddo
    456 !---------------------------------------------------------------------
    457 !  Definition of the run
    458 !---------------------------------------------------------------------
    459 
    460       call conf_gcm( 99, .TRUE. )
    461 !-----------------------------------------------------------------------
    462 !   Choix du calendrier
    463 !   -------------------
    464 
    465 !      calend = 'earth_365d'
    466       if (calend == 'earth_360d') then
    467         call ioconf_calendar('360d')
    468         write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
    469       else if (calend == 'earth_365d') then
    470         call ioconf_calendar('noleap')
    471         write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
    472       else if (calend == 'earth_366d') then
    473         call ioconf_calendar('all_leap')
    474         write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
    475       else if (calend == 'gregorian') then
    476         call ioconf_calendar('gregorian') ! not to be used by normal users
    477         write(*,*)'CALENDRIER CHOISI: Gregorien'
    478       else
    479         write (*,*) 'ERROR : unknown calendar ', calend
    480         stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
    481       endif
    482 !-----------------------------------------------------------------------
    483 !
    484 !c Date :
    485 !      La date est supposee donnee sous la forme [annee, numero du jour dans
    486 !      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
    487 !      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
    488 !      Le numero du jour est dans "day". L heure est traitee separement.
    489 !      La date complete est dans "daytime" (l'unite est le jour).
    490       if (nday>0) then
    491          fnday=nday
    492       else
    493          fnday=-nday/float(day_step)
    494       endif
    495       print *,'fnday=',fnday
    496 !     start_time doit etre en FRACTION DE JOUR
    497       start_time=time_ini/24.
    498 
    499 ! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
    500       IF(forcing_type .EQ. 61) fnday=53100./86400.
    501       IF(forcing_type .EQ. 103) fnday=53100./86400.
    502 ! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)
    503       IF(forcing_type .EQ. 6) fnday=64800./86400.
    504 !     IF(forcing_type .EQ. 6) fnday=50400./86400.
    505  IF(forcing_type .EQ. 8 ) fnday=129600./86400.
    506       annee_ref = anneeref
    507       mois = 1
    508       day_ref = dayref
    509       heure = 0.
    510       itau_dyn = 0
    511       itau_phy = 0
    512       call ymds2ju(annee_ref,mois,day_ref,heure,day)
    513       day_ini = int(day)
    514       day_end = day_ini + int(fnday)
    515 
    516       IF (forcing_type .eq.2) THEN
    517 ! Convert the initial date of Toga-Coare to Julian day
    518       call ymds2ju                                                          &
    519      & (year_ini_toga,mth_ini_toga,day_ini_toga,heure,day_ju_ini_toga)
    520 
    521       ELSEIF (forcing_type .eq.4) THEN
    522 ! Convert the initial date of TWPICE to Julian day
    523       call ymds2ju                                                          &
    524      & (year_ini_twpi,mth_ini_twpi,day_ini_twpi,heure_ini_twpi              &
    525      & ,day_ju_ini_twpi)
    526       ELSEIF (forcing_type .eq.6) THEN
    527 ! Convert the initial date of AMMA to Julian day
    528       call ymds2ju                                                          &
    529      & (year_ini_amma,mth_ini_amma,day_ini_amma,heure_ini_amma              &
    530      & ,day_ju_ini_amma)
    531       ELSEIF (forcing_type .eq.7) THEN
    532 ! Convert the initial date of DICE to Julian day
    533       call ymds2ju                                                         &
    534      & (year_ini_dice,mth_ini_dice,day_ini_dice,heure_ini_dice             &
    535      & ,day_ju_ini_dice)
    536  ELSEIF (forcing_type .eq.8 ) THEN
    537 ! Convert the initial date of GABLS4 to Julian day
    538       call ymds2ju                                                         &
    539      & (year_ini_gabls4,mth_ini_gabls4,day_ini_gabls4,heure_ini_gabls4     &
    540      & ,day_ju_ini_gabls4)
    541       ELSEIF (forcing_type .gt.100) THEN
    542 ! Convert the initial date to Julian day
    543       day_ini_cas=day_deb
    544       print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
    545       call ymds2ju                                                         &
    546      & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600            &
    547      & ,day_ju_ini_cas)
    548       print*,'time case 2',day_ini_cas,day_ju_ini_cas
    549       ELSEIF (forcing_type .eq.59) THEN
    550 ! Convert the initial date of Sandu case to Julian day
    551       call ymds2ju                                                          &
    552      &   (year_ini_sandu,mth_ini_sandu,day_ini_sandu,                       &
    553      &    time_ini*3600.,day_ju_ini_sandu)
    554 
    555       ELSEIF (forcing_type .eq.60) THEN
    556 ! Convert the initial date of Astex case to Julian day
    557       call ymds2ju                                                          &
    558      &   (year_ini_astex,mth_ini_astex,day_ini_astex,                        &
    559      &    time_ini*3600.,day_ju_ini_astex)
    560 
    561       ELSEIF (forcing_type .eq.61) THEN
    562 ! Convert the initial date of Arm_cu case to Julian day
    563       call ymds2ju                                                          &
    564      & (year_ini_armcu,mth_ini_armcu,day_ini_armcu,heure_ini_armcu          &
    565      & ,day_ju_ini_armcu)
    566       ENDIF
    567 
    568       IF (forcing_type .gt.100) THEN
    569       daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation
    570       ELSE
    571       daytime = day + time_ini/24. ! 1st day and initial time of the simulation
    572       ENDIF
    573 ! Print out the actual date of the beginning of the simulation :
    574       call ju2ymds(daytime,year_print, month_print,day_print,sec_print)
    575       print *,' Time of beginning : ',                                      &
    576      &        year_print, month_print, day_print, sec_print
    577 
    578 !---------------------------------------------------------------------
    579 ! Initialization of dimensions, geometry and initial state
    580 !---------------------------------------------------------------------
    581 !      call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
    582 !     but we still need to initialize dimphy module (klon,klev,etc.)  here.
    583       call init_dimphy(1,llm)
    584       call suphel
    585       call infotrac_init
    586 
    587       if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
    588       allocate(q(llm,nqtot)) ; q(:,:)=0.
    589       allocate(dq(llm,nqtot))
    590       allocate(dq_dyn(llm,nqtot))
    591       allocate(d_q_adv(llm,nqtot))
    592       allocate(d_q_nudge(llm,nqtot))
    593 !      allocate(d_th_adv(llm))
    594 
    595       q(:,:) = 0.
    596       dq(:,:) = 0.
    597       dq_dyn(:,:) = 0.
    598       d_q_adv(:,:) = 0.
    599       d_q_nudge(:,:) = 0.
    600 
    601 !
    602 !   No ozone climatology need be read in this pre-initialization
    603 !          (phys_state_var_init is called again in physiq)
    604       read_climoz = 0
    605 !
    606       call phys_state_var_init(read_climoz)
    607 
    608       if (ngrid.ne.klon) then
    609          print*,'stop in inifis'
    610          print*,'Probleme de dimensions :'
    611          print*,'ngrid = ',ngrid
    612          print*,'klon  = ',klon
    613          stop
    614       endif
    615 !!!=====================================================================
    616 !!! Feedback forcing values for Gateaux differentiation (al1)
    617 !!!=====================================================================
    618 !!! Surface Planck forcing bracketing call radiation
    619 !!      surf_Planck = 0.
    620 !!      surf_Conv   = 0.
    621 !!      write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv
    622 !!! a mettre dans le lmdz1d.def ou autre
    623 !!
    624 !!
    625       qsol = qsolinp
    626       qsurf = fq_sat(tsurf,psurf/100.)
    627       day1= day_ini
    628       time=daytime-day
    629       ts_toga(1)=tsurf ! needed by read_tsurf1d.F
    630       rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf))
    631 
    632 !
    633 !! mpl et jyg le 22/08/2012 :
    634 !!  pour que les cas a flux de surface imposes marchent
    635       IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
    636        fsens=-wtsurf*rcpd*rho(1)
    637        flat=-wqsurf*rlvtt*rho(1)
    638        print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
    639       ENDIF
    640       print*,'Flux sol ',fsens,flat
    641 !!      ok_flux_surf=.false.
    642 !!      fsens=-wtsurf*rcpd*rho(1)
    643 !!      flat=-wqsurf*rlvtt*rho(1)
    644 !!!!
    645 
    646 ! Vertical discretization and pressure levels at half and mid levels:
    647 
    648       pa   = 5e4
    649 !!      preff= 1.01325e5
    650       preff = psurf
    651       IF (ok_old_disvert) THEN
    652         call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
    653         print *,'On utilise disvert0'
    654         aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))
    655         bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))
    656         scaleheight=8.
    657         pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)
    658       ELSE
    659         call disvert()
    660         print *,'On utilise disvert'
    661 !       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
    662 !       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
    663       ENDIF
    664 
    665       sig_s=presnivs/preff
    666       plev =ap+bp*psurf
    667       play = 0.5*(plev(1:llm)+plev(2:llm+1))
    668       zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles
    669 
    670       IF (forcing_type .eq. 59) THEN
    671 ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
    672       write(*,*) '***********************'
    673       do l = 1, llm
    674        write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
    675        if (trouve_700 .and. play(l).le.70000) then
    676          llm700=l
    677          print *,'llm700,play=',llm700,play(l)/100.
    678          trouve_700= .false.
    679        endif
    680       enddo
    681       write(*,*) '***********************'
    682       ENDIF
    683 
    684 !
    685 !=====================================================================
    686 ! EVENTUALLY, READ FORCING DATA :
    687 !=====================================================================
    688 
    689 #include "1D_read_forc_cases.h"
    690 
    691       if (forcing_GCM2SCM) then
    692         write (*,*) 'forcing_GCM2SCM not yet implemented'
    693         stop 'in initialization'
    694       endif ! forcing_GCM2SCM
    695 
    696       print*,'mxcalc=',mxcalc
    697 !     print*,'zlay=',zlay(mxcalc)
    698       print*,'play=',play(mxcalc)
    699 
    700 !Al1 pour SST forced, appell?? depuis ocean_forced_noice
    701       ts_cur = tsurf ! SST used in read_tsurf1d
    702 !=====================================================================
    703 ! Initialisation de la physique :
    704 !=====================================================================
    705 
    706 !  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
    707 !
    708 ! day_step, iphysiq lus dans gcm.def ci-dessus
    709 ! timestep: calcule ci-dessous from rday et day_step
    710 ! ngrid=1
    711 ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
    712 ! rday: defini dans suphel.F (86400.)
    713 ! day_ini: lu dans run.def (dayref)
    714 ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
    715 ! airefi,zcufi,zcvfi initialises au debut de ce programme
    716 ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
    717       day_step = float(nsplit_phys)*day_step/float(iphysiq)
    718       write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
    719       timestep =rday/day_step
    720       dtime_frcg = timestep
    721 !
    722       zcufi=airefi
    723       zcvfi=airefi
    724 !
    725       rlat_rad(1)=xlat*rpi/180.
    726       rlon_rad(1)=xlon*rpi/180.
    727 
    728      ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
    729      ! e.g. for cell boundaries, which are meaningless in 1D; so pad these
    730      ! with '0.' when necessary
    731       call iniphysiq(iim,jjm,llm, &
    732            1,comm_lmdz, &
    733            rday,day_ini,timestep,  &
    734            (/rlat_rad(1),0./),(/0./), &
    735            (/0.,0./),(/rlon_rad(1),0./),  &
    736            (/ (/airefi,0./),(/0.,0./) /), &
    737            (/zcufi,0.,0.,0./), &
    738            (/zcvfi,0./), &
    739            ra,rg,rd,rcpd,1)
    740       print*,'apres iniphysiq'
    741 
    742 ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
    743       co2_ppm= 330.0
    744       solaire=1370.0
    745 
    746 ! Ecriture du startphy avant le premier appel a la physique.
    747 ! On le met juste avant pour avoir acces a tous les champs
    748 
    749       if (ok_writedem) then
    750 
    751 !--------------------------------------------------------------------------
    752 ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
    753 ! need : qsol fder snow qsurf evap rugos agesno ftsoil
    754 !--------------------------------------------------------------------------
    755 
    756         type_ocean = "force"
    757         run_off_lic_0(1) = restart_runoff
    758         call fonte_neige_init(run_off_lic_0)
    759 
    760         fder=0.
    761         snsrf(1,:)=snowmass ! masse de neige des sous surface
    762         qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
    763         fevap=0.
    764         z0m(1,:)=rugos     ! couverture de neige des sous surface
    765         z0h(1,:)=rugosh    ! couverture de neige des sous surface
    766         agesno  = xagesno
    767         tsoil(:,:,:)=tsurf
    768 !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
    769 !       tsoil(1,1,1)=299.18
    770 !       tsoil(1,2,1)=300.08
    771 !       tsoil(1,3,1)=301.88
    772 !       tsoil(1,4,1)=305.48
    773 !       tsoil(1,5,1)=308.00
    774 !       tsoil(1,6,1)=308.00
    775 !       tsoil(1,7,1)=308.00
    776 !       tsoil(1,8,1)=308.00
    777 !       tsoil(1,9,1)=308.00
    778 !       tsoil(1,10,1)=308.00
    779 !       tsoil(1,11,1)=308.00
    780 !-----------------------------------------------------------------------
    781         call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
    782 
    783 !------------------ prepare limit conditions for limit.nc -----------------
    784 !--   Ocean force
    785 
    786         print*,'avant phyredem'
    787         pctsrf(1,:)=0.
    788           if (nat_surf.eq.0.) then
    789           pctsrf(1,is_oce)=1.
    790           pctsrf(1,is_ter)=0.
    791           pctsrf(1,is_lic)=0.
    792           pctsrf(1,is_sic)=0.
    793         else if (nat_surf .eq. 1) then
    794           pctsrf(1,is_oce)=0.
    795           pctsrf(1,is_ter)=1.
    796           pctsrf(1,is_lic)=0.
    797           pctsrf(1,is_sic)=0.
    798         else if (nat_surf .eq. 2) then
    799           pctsrf(1,is_oce)=0.
    800           pctsrf(1,is_ter)=0.
    801           pctsrf(1,is_lic)=1.
    802           pctsrf(1,is_sic)=0.
    803         else if (nat_surf .eq. 3) then
    804           pctsrf(1,is_oce)=0.
    805           pctsrf(1,is_ter)=0.
    806           pctsrf(1,is_lic)=0.
    807           pctsrf(1,is_sic)=1.
    808 
    809      end if
    810 
    811 
    812         print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf         &
    813      &        ,pctsrf(1,is_oce),pctsrf(1,is_ter)
    814 
    815         zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)
    816         zpic = zpicinp
    817         ftsol=tsurf
    818         nsw=6 ! on met le nb de bandes SW=6, pour initialiser
    819               ! 6 albedo, mais on peut quand meme tourner avec
    820               ! moins. Seules les 2 ou 4 premiers seront lus
    821         falb_dir=albedo
    822         falb_dif=albedo
    823         rugoro=rugos
    824         t_ancien(1,:)=temp(:)
    825         q_ancien(1,:)=q(:,1)
    826         ql_ancien = 0.
    827         qs_ancien = 0.
    828         prlw_ancien = 0.
    829         prsw_ancien = 0.
    830         prw_ancien = 0.
    831 !jyg<
    832 !!        pbl_tke(:,:,:)=1.e-8
    833         pbl_tke(:,:,:)=0.
    834         pbl_tke(:,2,:)=1.e-2
    835         PRINT *, ' pbl_tke dans lmdz1d '
    836         if (prt_level .ge. 5) then
    837          DO nsrf = 1,4
    838            PRINT *,'pbl_tke(1,:,',nsrf,') ',pbl_tke(1,:,nsrf)
    839          ENDDO
    840         end if
    841 
    842 !>jyg
    843 
    844         rain_fall=0.
    845         snow_fall=0.
    846         solsw=0.
    847         sollw=0.
    848         sollwdown=rsigma*tsurf**4
    849         radsol=0.
    850         rnebcon=0.
    851         ratqs=0.
    852         clwcon=0.
    853         zmax0 = 0.
    854         zmea=0.
    855         zstd=0.
    856         zsig=0.
    857         zgam=0.
    858         zval=0.
    859         zthe=0.
    860         sig1=0.
    861         w01=0.
    862         wake_cstar = 0.
    863         wake_deltaq = 0.
    864         wake_deltat = 0.
    865         wake_delta_pbl_TKE(:,:,:) = 0.
    866         delta_tsurf = 0.
    867         wake_fip = 0.
    868         wake_pe = 0.
    869         wake_s = 0.
    870         wake_dens = 0.
    871         ale_bl = 0.
    872         ale_bl_trig = 0.
    873         alp_bl = 0.
    874         IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
    875         IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
    876         entr_therm = 0.
    877         detr_therm = 0.
    878         f0 = 0.
    879         fm_therm = 0.
    880         u_ancien(1,:)=u(:)
    881         v_ancien(1,:)=v(:)
    882  
    883 !------------------------------------------------------------------------
    884 ! Make file containing restart for the physics (startphy.nc)
    885 !
    886 ! NB: List of the variables to be written by phyredem (via put_field):
    887 ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
    888 ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
    889 ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
    890 ! radsol,solsw,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
    891 ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
    892 ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
    893 ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
    894 ! wake_deltat,wake_deltaq,wake_s,wake_dens,wake_cstar,
    895 ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
    896 !
    897 ! NB2: The content of the startphy.nc file depends on some flags defined in
    898 ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have
    899 ! to be set at some arbitratry convenient values.
    900 !------------------------------------------------------------------------
    901 !Al1 =============== restart option ==========================
    902         if (.not.restart) then
    903           iflag_pbl = 5
    904           call phyredem ("startphy.nc")
    905         else
    906 ! (desallocations)
    907         print*,'callin surf final'
    908           call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)
    909         print*,'after surf final'
    910           CALL fonte_neige_final(run_off_lic_0)
    911         endif
    912 
    913         ok_writedem=.false.
    914         print*,'apres phyredem'
    915 
    916       endif ! ok_writedem
    917      
    918 !------------------------------------------------------------------------
    919 ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
    920 ! --------------------------------------------------
    921 ! NB: List of the variables to be written in limit.nc
    922 !     (by writelim.F, subroutine of 1DUTILS.h):
    923 !        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
    924 !        phy_fter,phy_foce,phy_flic,phy_fsic)
    925 !------------------------------------------------------------------------
    926       do i=1,yd
    927         phy_nat(i)  = nat_surf
    928         phy_alb(i)  = albedo
    929         phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
    930         phy_rug(i)  = rugos
    931         phy_fter(i) = pctsrf(1,is_ter)
    932         phy_foce(i) = pctsrf(1,is_oce)
    933         phy_fsic(i) = pctsrf(1,is_sic)
    934         phy_flic(i) = pctsrf(1,is_lic)
    935       enddo
    936 
    937 ! fabrication de limit.nc
    938       call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,             &
    939      &               phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)
    940 
    941 
    942       call phys_state_var_end
    943 !Al1
    944       if (restart) then
    945         print*,'call to restart dyn 1d'
    946         Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs,          &
    947      &              u,v,temp,q,omega2)
    948 
    949        print*,'fnday,annee_ref,day_ref,day_ini',                            &
    950      &     fnday,annee_ref,day_ref,day_ini
    951 !**      call ymds2ju(annee_ref,mois,day_ini,heure,day)
    952        day = day_ini
    953        day_end = day_ini + nday
    954        daytime = day + time_ini/24. ! 1st day and initial time of the simulation
    955 
    956 ! Print out the actual date of the beginning of the simulation :
    957        call ju2ymds(daytime, an, mois, jour, heure)
    958        print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.
    959 
    960        day = int(daytime)
    961        time=daytime-day
    962  
    963        print*,'****** intialised fields from restart1dyn *******'
    964        print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
    965        print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
    966        print*,temp(1),q(1,1),u(1),v(1),plev(1),phis
    967 ! raz for safety
    968        do l=1,llm
    969          dq_dyn(l,1) = 0.
    970        enddo
    971       endif
    972 !Al1 ================  end restart =================================
    973       IF (ecrit_slab_oc.eq.1) then
    974          open(97,file='div_slab.dat',STATUS='UNKNOWN')
    975        elseif (ecrit_slab_oc.eq.0) then
    976          open(97,file='div_slab.dat',STATUS='OLD')
    977        endif
    978 !
    979 !---------------------------------------------------------------------
    980 !    Initialize target profile for RHT nudging if needed
    981 !---------------------------------------------------------------------
    982       if (nudge(inudge_RHT)) then
    983         call nudge_RHT_init(plev,play,temp,q(:,1),t_targ,rh_targ)
    984       endif
    985       if (nudge(inudge_UV)) then
    986         call nudge_UV_init(plev,play,u,v,u_targ,v_targ)
    987       endif
    988 !
    989 !=====================================================================
    990        CALL iophys_ini
    991 ! START OF THE TEMPORAL LOOP :
    992 !=====================================================================
    993            
    994       it_end = nint(fnday*day_step)
    995 !test JLD     it_end = 10
    996       do while(it.le.it_end)
    997 
    998        if (prt_level.ge.1) then
    999          print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
    1000      &             it,day,time,it_end,day_step
    1001          print*,'PAS DE TEMPS ',timestep
    1002        endif
    1003 !Al1 demande de restartphy.nc
    1004        if (it.eq.it_end) lastcall=.True.
    1005 
    1006 !---------------------------------------------------------------------
    1007 ! Interpolation of forcings in time and onto model levels
    1008 !---------------------------------------------------------------------
    1009 
    1010 #include "1D_interp_cases.h"
    1011 
    1012       if (forcing_GCM2SCM) then
    1013         write (*,*) 'forcing_GCM2SCM not yet implemented'
    1014         stop 'in time loop'
    1015       endif ! forcing_GCM2SCM
    1016 
    1017 !---------------------------------------------------------------------
    1018 !  Geopotential :
    1019 !---------------------------------------------------------------------
    1020 
    1021         phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
    1022         do l = 1, llm-1
    1023           phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
    1024      &    (play(l)-play(l+1))/(play(l)+play(l+1))
    1025         enddo
    1026 
    1027 !---------------------------------------------------------------------
    1028 ! Listing output for debug prt_level>=1
    1029 !---------------------------------------------------------------------
    1030        if (prt_level>=1) then
    1031          print *,' avant physiq : -------- day time ',day,time
    1032          write(*,*) 'firstcall,lastcall,phis',                               &
    1033      &               firstcall,lastcall,phis
    1034        end if
    1035        if (prt_level>=5) then
    1036          write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l',                   &
    1037      &        'presniv','plev','play','phi'
    1038          write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l,                   &
    1039      &         presnivs(l),plev(l),play(l),phi(l),l=1,llm)
    1040          write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l',                    &
    1041      &         'presniv','u','v','temp','q1','q2','omega2'
    1042          write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l,         &
    1043      &   presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
    1044        endif
    1045 
    1046 !---------------------------------------------------------------------
    1047 !   Call physiq :
    1048 !---------------------------------------------------------------------
    1049        call physiq(ngrid,llm, &
    1050                     firstcall,lastcall,timestep, &
    1051                     plev,play,phi,phis,presnivs, &
    1052                     u,v, rot, temp,q,omega2, &
    1053                     du_phys,dv_phys,dt_phys,dq,dpsrf)
    1054                 firstcall=.false.
    1055 
    1056 !---------------------------------------------------------------------
    1057 ! Listing output for debug
    1058 !---------------------------------------------------------------------
    1059         if (prt_level>=5) then
    1060           write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l',                  &
    1061      &        'presniv','plev','play','phi'
    1062           write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l,                  &
    1063      &    presnivs(l),plev(l),play(l),phi(l),l=1,llm)
    1064           write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l',                   &
    1065      &         'presniv','u','v','temp','q1','q2','omega2'
    1066           write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l,       &
    1067      &    presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
    1068           write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l',                   &
    1069      &         'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'   
    1070            write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l,            &
    1071      &      presnivs(l),86400*du_phys(l),86400*dv_phys(l),                   &
    1072      &       86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)
    1073           write(*,*) 'dpsrf',dpsrf
    1074         endif
    1075 !---------------------------------------------------------------------
    1076 !   Add physical tendencies :
    1077 !---------------------------------------------------------------------
    1078 
    1079        fcoriolis=2.*sin(rpi*xlat/180.)*romega
    1080        if (forcing_radconv .or. forcing_fire) then
    1081          fcoriolis=0.0
    1082          dt_cooling=0.0
    1083          d_t_adv=0.0
    1084          d_q_adv=0.0
    1085        endif
    1086 !      print*, 'calcul de fcoriolis ', fcoriolis
    1087 
    1088        if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
    1089      &    .or.forcing_amma .or. forcing_type.eq.101) then
    1090          fcoriolis=0.0 ; ug=0. ; vg=0.
    1091        endif
    1092 
    1093        if(forcing_rico) then
    1094           dt_cooling=0.
    1095        endif
    1096 
    1097 !CRio:Attention modif sp??cifique cas de Caroline
    1098       if (forcing_type==-1) then
    1099          fcoriolis=0.
    1100 !Nudging
    1101        
    1102 !on calcule dt_cooling
    1103         do l=1,llm
    1104         if (play(l).ge.20000.) then
    1105             dt_cooling(l)=-1.5/86400.
    1106         elseif ((play(l).ge.10000.).and.((play(l).lt.20000.))) then
    1107             dt_cooling(l)=-1.5/86400.*(play(l)-10000.)/(10000.)-1./86400.*(20000.-play(l))/10000.*(temp(l)-200.)
    1108         else
    1109             dt_cooling(l)=-1.*(temp(l)-200.)/86400.
    1110         endif
    1111         enddo
    1112 
    1113       endif     
    1114 !RC
    1115       if (forcing_sandu) then
    1116          ug(1:llm)=u_mod(1:llm)
    1117          vg(1:llm)=v_mod(1:llm)
    1118       endif
    1119 
    1120       IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &
    1121                                    fcoriolis, xlat,mxcalc
    1122 
    1123 !       print *,'u-ug=',u-ug
    1124 
    1125 !!!!!!!!!!!!!!!!!!!!!!!!
    1126 ! Geostrophic wind
    1127 ! Le calcul ci dessous est insuffisamment precis
    1128 !      du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
    1129 !      dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
    1130 !!!!!!!!!!!!!!!!!!!!!!!!
    1131        sfdt = sin(0.5*fcoriolis*timestep)
    1132        cfdt = cos(0.5*fcoriolis*timestep)
    1133 !       print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep
    1134 !
    1135         du_age(1:mxcalc)= -2.*sfdt/timestep*                                &
    1136      &          (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
    1137      &           cfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
    1138 !!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
    1139 !
    1140        dv_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
    1141      &          (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
    1142      &           sfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
    1143 !!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
    1144 !
    1145 !!!!!!!!!!!!!!!!!!!!!!!!
    1146 !  Nudging
    1147 !!!!!!!!!!!!!!!!!!!!!!!!
    1148       d_t_nudge(:) = 0.
    1149       d_q_nudge(:,:) = 0.
    1150       d_u_nudge(:) = 0.
    1151       d_v_nudge(:) = 0.
    1152       if (nudge(inudge_RHT)) then
    1153         call nudge_RHT(timestep,plev,play,t_targ,rh_targ,temp,q(:,1),     &
    1154     &                  d_t_nudge,d_q_nudge(:,1))
    1155       endif
    1156       if (nudge(inudge_UV)) then
    1157         call nudge_UV(timestep,plev,play,u_targ,v_targ,u,v,     &
    1158     &                  d_u_nudge,d_v_nudge)
    1159       endif
    1160 !
    1161 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1162 !         call  writefield_phy('dv_age' ,dv_age,llm)
    1163 !         call  writefield_phy('du_age' ,du_age,llm)
    1164 !         call  writefield_phy('du_phys' ,du_phys,llm)
    1165 !         call  writefield_phy('u_tend' ,u,llm)
    1166 !         call  writefield_phy('u_g' ,ug,llm)
    1167 !
    1168 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1169 !! Increment state variables
    1170 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1171     IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
    1172 
    1173 ! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h
    1174 ! au dessus de 700hpa, on relaxe vers les profils initiaux
    1175       if (forcing_sandu .OR. forcing_astex) then
    1176 #include "1D_nudge_sandu_astex.h"
    1177       else
    1178         u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &
    1179      &              du_phys(1:mxcalc)                                       &
    1180      &             +du_age(1:mxcalc)+du_adv(1:mxcalc)                       &
    1181      &             +d_u_nudge(1:mxcalc) )           
    1182         v(1:mxcalc)=v(1:mxcalc) + timestep*(                                 &
    1183      &              dv_phys(1:mxcalc)                                       &
    1184      &             +dv_age(1:mxcalc)+dv_adv(1:mxcalc)                       &
    1185      &             +d_v_nudge(1:mxcalc) )
    1186         q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(                              &
    1187      &                dq(1:mxcalc,:)                                        &
    1188      &               +d_q_adv(1:mxcalc,:)                                   &
    1189      &               +d_q_nudge(1:mxcalc,:) )
    1190 
    1191         if (prt_level.ge.3) then
    1192           print *,                                                          &
    1193      &    'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ',         &
    1194      &              temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)
    1195            print* ,'dv_phys=',dv_phys
    1196            print* ,'dv_age=',dv_age
    1197            print* ,'dv_adv=',dv_adv
    1198            print* ,'d_v_nudge=',d_v_nudge
    1199            print*, v
    1200            print*, vg
    1201         endif
    1202 
    1203         temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
    1204      &              dt_phys(1:mxcalc)                                       &
    1205      &             +d_t_adv(1:mxcalc)                                      &
    1206      &             +d_t_nudge(1:mxcalc)                                      &
    1207      &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
    1208 
    1209       endif  ! forcing_sandu or forcing_astex
    1210 
    1211         teta=temp*(pzero/play)**rkappa
    1212 !
    1213 !---------------------------------------------------------------------
    1214 !   Nudge soil temperature if requested
    1215 !---------------------------------------------------------------------
    1216 
    1217       IF (nudge_tsoil .AND. .NOT. lastcall) THEN
    1218        ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
    1219      &  -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
    1220       ENDIF
    1221 
    1222 !---------------------------------------------------------------------
    1223 !   Add large-scale tendencies (advection, etc) :
    1224 !---------------------------------------------------------------------
    1225 
    1226 !cc nrlmd
    1227 !cc        tmpvar=teta
    1228 !cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
    1229 !cc
    1230 !cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
    1231 !cc        tmpvar(:)=q(:,1)
    1232 !cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
    1233 !cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
    1234 !cc        tmpvar(:)=q(:,2)
    1235 !cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
    1236 !cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
    1237 
    1238    END IF ! end if tendency of tendency should be added
    1239 
    1240 !---------------------------------------------------------------------
    1241 !   Air temperature :
    1242 !---------------------------------------------------------------------       
    1243         if (lastcall) then
    1244           print*,'Pas de temps final ',it
    1245           call ju2ymds(daytime, an, mois, jour, heure)
    1246           print*,'a la date : a m j h',an, mois, jour ,heure/3600.
    1247         endif
    1248 
    1249 !  incremente day time
    1250 !        print*,'daytime bef',daytime,1./day_step
    1251         daytime = daytime+1./day_step
    1252 !Al1dbg
    1253         day = int(daytime+0.1/day_step)
    1254 !        time = max(daytime-day,0.0)
    1255 !Al1&jyg: correction de bug
    1256 !cc        time = real(mod(it,day_step))/day_step
    1257         time = time_ini/24.+real(mod(it,day_step))/day_step
    1258 !        print*,'daytime nxt time',daytime,time
    1259         it=it+1
    1260 
    1261       enddo
    1262 
    1263 !Al1
    1264       if (ecrit_slab_oc.ne.-1) close(97)
    1265 
    1266 !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
    1267 ! -------------------------------------
    1268        call dyn1dredem("restart1dyn.nc",                                    &
    1269      &              plev,play,phi,phis,presnivs,                            &
    1270      &              u,v,temp,q,omega2)
    1271 
    1272         CALL abort_gcm ('lmdz1d   ','The End  ',0)
    1273 
    1274       end
    127527
    127628#include "1DUTILS.h"

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/mod_1D_cases_read2.F90

    r2764 r3605  
    315315END SUBROUTINE read2_1D_cas
    316316
     317!**********************************************************************************************
     318SUBROUTINE read_SCM_cas
     319      implicit none
     320
     321#include "netcdf.inc"
     322#include "date_cas.h"
     323
     324      INTEGER nid,rid,ierr
     325      INTEGER ii,jj,timeid
     326      REAL, ALLOCATABLE :: time_val(:)
     327
     328      print*,'ON EST VRAIMENT LA'
     329      fich_cas='cas.nc'
     330      print*,'fich_cas ',fich_cas
     331      ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
     332      print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
     333      if (ierr.NE.NF_NOERR) then
     334         write(*,*) 'ERROR: GROS Pb opening forcings nc file '
     335         write(*,*) NF_STRERROR(ierr)
     336         stop ""
     337      endif
     338!.......................................................................
     339      ierr=NF_INQ_DIMID(nid,'lat',rid)
     340      IF (ierr.NE.NF_NOERR) THEN
     341         print*, 'Oh probleme lecture dimension lat'
     342      ENDIF
     343      ierr=NF_INQ_DIMLEN(nid,rid,ii)
     344      print*,'OK1 read2: nid,rid,lat',nid,rid,ii
     345!.......................................................................
     346      ierr=NF_INQ_DIMID(nid,'lon',rid)
     347      IF (ierr.NE.NF_NOERR) THEN
     348         print*, 'Oh probleme lecture dimension lon'
     349      ENDIF
     350      ierr=NF_INQ_DIMLEN(nid,rid,jj)
     351      print*,'OK2 read2: nid,rid,lat',nid,rid,jj
     352!.......................................................................
     353      ierr=NF_INQ_DIMID(nid,'lev',rid)
     354      IF (ierr.NE.NF_NOERR) THEN
     355         print*, 'Oh probleme lecture dimension nlev'
     356      ENDIF
     357      ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
     358      print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas
     359      IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 1000 )) THEN
     360              print*,'Valeur de nlev_cas peu probable'
     361              STOP
     362      ENDIF
     363!.......................................................................
     364      ierr=NF_INQ_DIMID(nid,'time',rid)
     365      nt_cas=0
     366      IF (ierr.NE.NF_NOERR) THEN
     367        stop 'Oh probleme lecture dimension time'
     368      ENDIF
     369      ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
     370      print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas
     371! Lecture de l'axe des temps
     372      print*,'LECTURE DU TEMPS'
     373      ierr=NF_INQ_VARID(nid,'time',timeid)
     374         if(ierr/=NF_NOERR) then
     375           print *,'Variable time manquante dans cas.nc:'
     376           ierr=NF_NOERR
     377         else
     378                 allocate(time_val(nt_cas))
     379#ifdef NC_DOUBLE
     380         ierr = NF_GET_VAR_DOUBLE(nid,timeid,time_val)
     381#else
     382           ierr = NF_GET_VAR_REAL(nid,timeid,time_val)
     383#endif
     384           if(ierr/=NF_NOERR) then
     385              print *,'Pb a la lecture de time cas.nc: '
     386           endif
     387   endif
     388   IF (nt_cas>1) THEN
     389           pdt_cas=time_val(2)-time_val(1)
     390   ELSE
     391           pdt_cas=0.
     392   ENDIF
     393
     394
     395!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     396!profils moyens:
     397        allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))       
     398        allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
     399        allocate(ap_cas(nlev_cas+1),bp_cas(nt_cas+1))
     400        allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
     401             qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
     402        allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
     403        allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
     404
     405!forcing
     406        allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
     407        allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
     408        allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
     409        allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
     410        allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
     411        allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
     412        allocate(ug_cas(nlev_cas,nt_cas))
     413        allocate(vg_cas(nlev_cas,nt_cas))
     414        allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tke_cas(nt_cas))
     415        allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
     416
     417
     418
     419!champs interpoles
     420        allocate(plev_prof_cas(nlev_cas))
     421        allocate(t_prof_cas(nlev_cas))
     422        allocate(theta_prof_cas(nlev_cas))
     423        allocate(thl_prof_cas(nlev_cas))
     424        allocate(thv_prof_cas(nlev_cas))
     425        allocate(q_prof_cas(nlev_cas))
     426        allocate(qv_prof_cas(nlev_cas))
     427        allocate(ql_prof_cas(nlev_cas))
     428        allocate(qi_prof_cas(nlev_cas))
     429        allocate(rh_prof_cas(nlev_cas))
     430        allocate(rv_prof_cas(nlev_cas))
     431        allocate(u_prof_cas(nlev_cas))
     432        allocate(v_prof_cas(nlev_cas))
     433        allocate(vitw_prof_cas(nlev_cas))
     434        allocate(omega_prof_cas(nlev_cas))
     435        allocate(ug_prof_cas(nlev_cas))
     436        allocate(vg_prof_cas(nlev_cas))
     437        allocate(ht_prof_cas(nlev_cas))
     438        allocate(hth_prof_cas(nlev_cas))
     439        allocate(hq_prof_cas(nlev_cas))
     440        allocate(hu_prof_cas(nlev_cas))
     441        allocate(hv_prof_cas(nlev_cas))
     442        allocate(vt_prof_cas(nlev_cas))
     443        allocate(vth_prof_cas(nlev_cas))
     444        allocate(vq_prof_cas(nlev_cas))
     445        allocate(vu_prof_cas(nlev_cas))
     446        allocate(vv_prof_cas(nlev_cas))
     447        allocate(dt_prof_cas(nlev_cas))
     448        allocate(dth_prof_cas(nlev_cas))
     449        allocate(dtrad_prof_cas(nlev_cas))
     450        allocate(dq_prof_cas(nlev_cas))
     451        allocate(du_prof_cas(nlev_cas))
     452        allocate(dv_prof_cas(nlev_cas))
     453        allocate(uw_prof_cas(nlev_cas))
     454        allocate(vw_prof_cas(nlev_cas))
     455        allocate(q1_prof_cas(nlev_cas))
     456        allocate(q2_prof_cas(nlev_cas))
     457
     458        print*,'Allocations OK'
     459        call read_SCM (nid,nlev_cas,nt_cas,                                                                     &
     460     &     ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                    &
     461     &     ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,ug_cas,vg_cas,du_cas,hu_cas,vu_cas,        &
     462     &     dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
     463     &     dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,ps_cas,ustar_cas,tke_cas,                      &
     464     &     uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough, &
     465     &     o3_cas,rugos_cas,clay_cas,sand_cas)
     466        print*,'Read2 cas OK'
     467        do ii=1,nlev_cas
     468        print*,'apres read2_cas, plev_cas=',ii,plev_cas(ii,1)
     469        enddo
     470
     471
     472END SUBROUTINE read_SCM_cas
    317473
    318474
    … …  
    685841!-----------------------------------------------------------------------
    686842
     843
    687844         return
    688845         end subroutine read2_cas
     846
     847!======================================================================
     848      subroutine read_SCM(nid,nlevel,ntime,                                       &
     849     &     ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,ug,vg,&
     850     &     du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
     851     &     dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,ps,ustar,tke,uw,vw,q1,q2,       &
     852     &     orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,          &
     853     &     heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
     854
     855!program reading forcing of the case study
     856      implicit none
     857#include "netcdf.inc"
     858
     859      integer ntime,nlevel,k,t
     860
     861      real ap(nlevel+1),bp(nlevel+1)
     862      real zz(nlevel,ntime),zzh(nlevel+1)
     863      real pp(nlevel,ntime),pph(nlevel+1)
     864!profils initiaux
     865      real temp0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel),tke0(nlevel)
     866      real pp0(nlevel)   
     867      real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
     868      real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
     869      real u(nlevel,ntime),v(nlevel,ntime),tke(nlevel,ntime)
     870      real ug(nlevel,ntime),vg(nlevel,ntime)
     871      real vitw(nlevel,ntime),omega(nlevel,ntime)
     872      real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
     873      real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
     874      real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
     875      real dtrad(nlevel,ntime)
     876      real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
     877      real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
     878      real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
     879      real flat(ntime),sens(ntime),ustar(ntime)
     880      real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
     881      real ts(ntime),ps(ntime)
     882      real orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
     883      real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
     884
     885
     886      integer nid, ierr,ierr1,ierr2,rid,i
     887      integer nbvar3d
     888      parameter(nbvar3d=70)
     889      integer var3didin(nbvar3d),missing_var(nbvar3d)
     890      character*13 name_var(1:nbvar3d)
     891      data name_var/'coor_par_a','coor_par_b','height_h','pressure_h',&
     892     &'temp','qv','ql','qi','u','v','tke','pressure',&
     893     &'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','tadv','tadvh','tadvv',&
     894     &'qvadv','qvadvh','qvadvv','thadv','thadvh','thadvv','thladvh','radv','radvh','radvv','radcool','q1','q2','ustress','vstress', &
     895     'rh',&
     896     &'height_f','pressure_forc','tempt','theta','thv','thl','qvt','qlt','qit','rv','ut','vt','tket',&
     897     &'sfc_sens_flx','sfc_lat_flx','ts','ps','ustar',&
     898     &'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough','o3','rugos','clay','sand'/
     899      do i=1,nbvar3d
     900        missing_var(i)=0.
     901      enddo
     902
     903!-----------------------------------------------------------------------
     904
     905     print*,'ON EST LA'
     906       do i=1,nbvar3d
     907         ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i))
     908         if(ierr/=NF_NOERR) then
     909           print *,'Variable manquante dans cas.nc:',i,name_var(i)
     910           ierr=NF_NOERR
     911           missing_var(i)=1
     912         else
     913!-----------------------------------------------------------------------
     914           if(i.LE.4) then     ! Lecture des coord pression en (nlevelp1,lat,lon)
     915#ifdef NC_DOUBLE
     916           ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),apbp)
     917#else
     918           ierr = NF_GET_VAR_REAL(nid,var3didin(i),apbp)
     919#endif
     920           print *,'read2_cas(apbp), on a lu ',i,name_var(i)
     921           if(ierr/=NF_NOERR) then
     922              print *,'Pb a la lecture de cas.nc: ',name_var(i)
     923              stop "getvarup"
     924           endif
     925!-----------------------------------------------------------------------
     926           else if(i.gt.4.and.i.LE.12) then   ! Lecture des variables en (time,nlevel,lat,lon)
     927#ifdef NC_DOUBLE
     928           ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul1)
     929#else
     930           ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul1)
     931#endif
     932           print *,'read2_cas(resul1), on a lu ',i,name_var(i)
     933           if(ierr/=NF_NOERR) then
     934              print *,'Pb a la lecture de cas.nc: ',name_var(i)
     935              stop "getvarup"
     936           endif
     937         print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1)
     938!-----------------------------------------------------------------------
     939           else if(i.gt.12.and.i.LE.54) then   ! Lecture des variables en (time,nlevel,lat,lon)
     940#ifdef NC_DOUBLE
     941           ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul)
     942#else
     943           ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul)
     944#endif
     945           print *,'read2_cas(resul), on a lu ',i,name_var(i)
     946           if(ierr/=NF_NOERR) then
     947              print *,'Pb a la lecture de cas.nc: ',name_var(i)
     948              stop "getvarup"
     949           endif
     950         print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul)
     951!-----------------------------------------------------------------------
     952           else if (i.gt.54.and.i.LE.65) then   ! Lecture des variables en (time,lat,lon)
     953#ifdef NC_DOUBLE
     954           ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul2)
     955#else
     956           ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul2)
     957#endif
     958           print *,'read2_cas(resul2), on a lu ',i,name_var(i)
     959           if(ierr/=NF_NOERR) then
     960              print *,'Pb a la lecture de cas.nc: ',name_var(i)
     961              stop "getvarup"
     962           endif
     963         print*,'Lecture de la variable #i  ',i,name_var(i),minval(resul2),maxval(resul2)
     964!-----------------------------------------------------------------------
     965           else     ! Lecture des constantes (lat,lon)
     966#ifdef NC_DOUBLE
     967           ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul3)
     968#else
     969           ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul3)
     970#endif
     971           print *,'read2_cas(resul3), on a lu ',i,name_var(i)
     972           if(ierr/=NF_NOERR) then
     973              print *,'Pb a la lecture de cas.nc: ',name_var(i)
     974              stop "getvarup"
     975           endif
     976         print*,'Lecture de la variable #i ',i,name_var(i),resul3
     977           endif
     978         endif
     979!-----------------------------------------------------------------------
     980         select case(i)
     981         !case(1) ; ap=apbp       ! donnees indexees en nlevel+1
     982         ! case(2) ; bp=apbp
     983           case(3) ; zzh=apbp
     984           case(4) ; pph=apbp
     985           case(5) ; temp0=resul1    ! donnees initiales
     986           case(6) ; qv0=resul1
     987           case(7) ; ql0=resul1
     988           case(8) ; qi0=resul1
     989           case(9) ; u0=resul1
     990           case(10) ; v0=resul1
     991           case(11) ; tke0=resul1
     992           case(12) ; pp0=resul1
     993           case(13) ; vitw=resul    ! donnees indexees en nlevel,time
     994           case(14) ; omega=resul
     995           case(15) ; ug=resul
     996           case(16) ; vg=resul
     997           case(17) ; du=resul
     998           case(18) ; hu=resul
     999           case(19) ; vu=resul
     1000           case(20) ; dv=resul
     1001           case(21) ; hv=resul
     1002           case(22) ; vv=resul
     1003           case(23) ; dt=resul
     1004           case(24) ; ht=resul
     1005           case(25) ; vt=resul
     1006           case(26) ; dq=resul
     1007           case(27) ; hq=resul
     1008           case(28) ; vq=resul
     1009           case(29) ; dth=resul
     1010           case(30) ; hth=resul
     1011           case(31) ; vth=resul
     1012           case(32) ; hthl=resul
     1013           case(33) ; dr=resul
     1014           case(34) ; hr=resul
     1015           case(35) ; vr=resul
     1016           case(36) ; dtrad=resul
     1017           case(37) ; q1=resul
     1018           case(38) ; q2=resul
     1019           case(39) ; uw=resul
     1020           case(40) ; vw=resul
     1021           case(41) ; rh=resul
     1022           case(42) ; zz=resul      ! donnees en time,nlevel pour profil initial
     1023           case(43) ; pp=resul
     1024           case(44) ; temp=resul
     1025           case(45) ; theta=resul
     1026           case(46) ; thv=resul
     1027           case(47) ; thl=resul
     1028           case(48) ; qv=resul
     1029           case(49) ; ql=resul
     1030           case(50) ; qi=resul
     1031           case(51) ; rv=resul
     1032           case(52) ; u=resul
     1033           case(53) ; v=resul
     1034           case(54) ; tke=resul
     1035           case(55) ; sens=resul2   ! donnees indexees en time
     1036           case(56) ; flat=resul2
     1037           case(57) ; ts=resul2
     1038           case(58) ; ps=resul2
     1039           case(59) ; ustar=resul2
     1040           case(60) ; orog_cas=resul3      ! constantes
     1041           case(61) ; albedo_cas=resul3
     1042           case(62) ; emiss_cas=resul3
     1043           case(63) ; t_skin_cas=resul3
     1044           case(64) ; q_skin_cas=resul3
     1045           case(65) ; mom_rough=resul3
     1046           case(66) ; heat_rough=resul3
     1047           case(67) ; o3_cas=resul3       
     1048           case(68) ; rugos_cas=resul3
     1049           case(69) ; clay_cas=resul3
     1050           case(70) ; sand_cas=resul3
     1051         end select
     1052         resul=0.
     1053         resul1=0.
     1054         resul2=0.
     1055         resul3=0.
     1056       enddo
     1057         print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens)
     1058         print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat)
     1059
     1060!CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL
     1061       do t=1,ntime
     1062          do k=1,nlevel
     1063             temp(k,t)=temp0(k)
     1064             qv(k,t)=qv0(k)
     1065             ql(k,t)=ql0(k)
     1066             qi(k,t)=qi0(k)
     1067             u(k,t)=u0(k)
     1068             v(k,t)=v0(k)
     1069             tke(k,t)=tke0(k)
     1070          enddo
     1071       enddo
     1072!-----------------------------------------------------------------------
     1073
     1074         return
     1075         end subroutine read_SCM
     1076!======================================================================
     1077
    6891078!======================================================================
    6901079        SUBROUTINE interp_case_time2(day,day1,annee_ref                &
Note: See TracChangeset for help on using the changeset viewer.