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:
1 deleted
102 edited
18 copied

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Ocean_skin

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/aer_sedimnt.F90

    • Property svn:keywords set to Id
    r2752 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE AER_SEDIMNT(pdtphys, t_seri, pplay, paprs, tr_seri, dens_aer)
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/aerophys.F90

    • Property svn:keywords set to Id

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/calcaerosolstrato_rrtm.F90

    • Property svn:keywords set to Id
    r2715 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE calcaerosolstrato_rrtm(pplay,t_seri,paprs,debut)
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/coagulate.F90

    • Property svn:keywords set to Id
    r2950 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE COAGULATE(pdtcoag,mdw,tr_seri,t_seri,pplay,dens_aer,is_strato)
    25  !     -----------------------------------------------------------------------

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/cond_evap_tstep_mod.F90

    • Property svn:keywords set to Id
    r2695 r3605  
     1!
     2! $Id$
     3!
    14MODULE cond_evap_tstep_mod
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/interp_sulf_input.F90

    • Property svn:keywords set to Id
    r3097 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE interp_sulf_input(debutphy,pdtphys,paprs,tr_seri)
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/micphy_tstep.F90

    • Property svn:keywords set to Id
    r3098 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE micphy_tstep(pdtphys,tr_seri,t_seri,pplay,paprs,rh,is_strato)
    25
     6  USE geometry_mod, ONLY : latitude_deg !NL- latitude corr. to local domain
    37  USE dimphy, ONLY : klon,klev
    48  USE aerophys
    … …  
    913  USE sulfate_aer_mod, ONLY : STRAACT
    1014  USE YOMCST, ONLY : RPI, RD, RG
    11 
     15  USE print_control_mod, ONLY: lunout
     16  USE strataer_mod
     17 
    1218  IMPLICIT NONE
    1319
    … …  
    8995      ! compute nucleation rate in kg(H2SO4)/kgA/s
    9096      CALL nucleation_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev),rh(ilon,ilev), &
    91              & a_xm,b_xm,c_xm,nucl_rate,ntot,x)
     97           & a_xm,b_xm,c_xm,nucl_rate,ntot,x)
     98      !NL - add nucleation box (if flag on)
     99      IF (flag_nuc_rate_box) THEN
     100         IF (latitude_deg(ilon).LE.nuclat_min .OR. latitude_deg(ilon).GE.nuclat_max &
     101              .OR. pplay(ilon,ilev).GE.nucpres_max .AND. pplay(ilon,ilev).LE.nucpres_min) THEN
     102            nucl_rate=0.0
     103         ENDIF
     104      ENDIF
    92105      ! compute cond/evap rate in kg(H2SO4)/kgA/s
    93106      CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
    … …  
    160173    DO it=1, nbtr
    161174      IF (tr_seri(ilon,ilev,it).LT.0.0) THEN
    162         PRINT *, 'micphy_tstep: negative concentration', tr_seri(ilon,ilev,it), ilon, ilev, it
     175         WRITE(lunout,*) 'micphy_tstep: negative concentration', tr_seri(ilon,ilev,it), ilon, ilev, it
    163176      ENDIF
    164177    ENDDO

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/miecalc_aer.F90

    • Property svn:keywords set to Id
    r2948 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE MIECALC_AER(tau_strat, piz_strat, cg_strat, tau_strat_wave, tau_lw_abs_rrtm, paprs, debut)
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/minmaxsimple.F90

    • Property svn:keywords set to Id
    r2690 r3605  
    11!
    2 ! $Id: minmaxsimple.F90 1910 2013-11-29 08:40:25Z fairhead $
     2! $Id$
    33!
    44SUBROUTINE minmaxsimple(zq,qmin,qmax,comment)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/nucleation_tstep_mod.F90

    • Property svn:keywords set to Id
    r2695 r3605  
     1!
     2! $Id$
     3!
    14MODULE nucleation_tstep_mod
    25
    36CONTAINS
    47
    5 SUBROUTINE nucleation_rate(rhoa,t_seri,pplay,rh,a_xm,b_xm,c_xm,nucl_rate,ntot,x)
     8SUBROUTINE nucleation_rate(rhoa,t_seri,pplay,rh,a_xm,b_xm,c_xm,nucl_rate,ntot_n,x_n)
    69
    710  USE aerophys
    811  USE infotrac
    9   USE YOMCST, ONLY : RPI, RD
     12  USE YOMCST, ONLY : RPI, RD, RMD, RKBOL, RNAVO
    1013
    1114  IMPLICIT NONE
    1215
    1316  ! input variables
    14   REAL rhoa !H2SO4 number density [molecules/cm3]
    15   REAL t_seri
    16   REAL pplay
    17   REAL rh
     17  LOGICAL, PARAMETER :: flag_new_nucl=.TRUE.
     18  REAL rhoa    ! H2SO4 number density [molecules/cm3]
     19  REAL t_seri  ! temperature (K)
     20  REAL pplay   ! pressure (Pa)
     21  REAL rh      ! relative humidity (between 0 and 1)
    1822  REAL a_xm, b_xm, c_xm
    1923
    2024  ! output variables
    2125  REAL nucl_rate
    22   REAL ntot ! total number of molecules in the critical cluster
    23   REAL x    ! molefraction of H2SO4 in the critical cluster
     26  REAL ntot_n ! total number of molecules in the critical cluster for neutral nucleation
     27  REAL x_n    ! mole fraction of H2SO4 in the critical cluster for neutral nucleation
    2428
    2529  ! local variables
    26   REAL, PARAMETER                               :: k_B=1.3806E-23  ! Boltzmann constant [J/K]
    27   REAL                                          :: jnuc !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s)
    28   REAL                                          :: rc   !radius of the critical cluster in nm
     30  REAL jnuc_n ! nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s) for neutral nucleation
     31  REAL rc_n   ! radius of the critical cluster in nm for neutral nucleation
     32  REAL na_n   ! sulfuric acid molecules in the neutral critical cluster (NOT IN USE)
     33  LOGICAL kinetic_n ! true if kinetic neutral nucleation (NOT IN USE)
     34  LOGICAL kinetic_i ! true if kinetic ion-induced nucleation (NOT IN USE)
     35  REAL rhoatres ! threshold concentration of H2SO4 (1/cm^3) for neutral kinetic nucleation (NOT IN USE)
    2936  REAL VH2SO4mol
     37  REAL ntot_i, x_i, jnuc_i, rc_i, na_i, n_i ! quantities for charged nucleation (NOT IN USE)
     38  REAL csi     ! Ion condensation sink (s-1) NOT IN USE
     39  REAL airn    ! Air molecule concentration in (cm-3) NOT IN USE
     40  REAL ipr     ! Ion pair production rate (cm-3 s-1) NOT IN USE
    3041
    3142  ! call nucleation routine
    32   CALL binapara(t_seri,rh,rhoa,jnuc,x,ntot,rc)
    33 
    34   IF (ntot < 4.0) THEN
    35     !set jnuc to collision rate of two H2SO4 molecules (following personal communication of Ulrike Niemeier and Hanna Vehkamäki)
    36     VH2SO4mol=mH2SO4mol/(1.e-3*(a_xm+t_seri*(b_xm+t_seri*c_xm))) !cm3
    37     jnuc = rhoa**2. *(3./4.*RPI)**(1./6.) *(12.*k_B*t_seri/mH2SO4mol)**0.5 &
    38          & *100.*(2.*VH2SO4mol**(1./3.))**2. !1/(cm3s)
    39     ntot=2.0
    40     x=1.0
    41   ENDIF
    42 
    43   ! convert jnuc from particles/cm3/s to kg(H2SO4)/kgA/s
    44   nucl_rate=jnuc*ntot*x*mH2SO4mol/(pplay/t_seri/RD/1.E6)
     43  IF (.NOT.flag_new_nucl) THEN
     44    ! Use older routine from Hanna Vehkamäki (FMI)
     45    CALL binapara(t_seri,rh,rhoa,jnuc_n,x_n,ntot_n,rc_n)
     46    ! when total number of molecules is too small
     47    ! then set jnuc_n to collision rate of two H2SO4 molecules (following personal communication of Ulrike Niemeier and Hanna Vehkamäki)
     48    IF (ntot_n < 4.0) THEN
     49      VH2SO4mol=mH2SO4mol/(1.E-3*(a_xm+t_seri*(b_xm+t_seri*c_xm))) !cm3
     50      jnuc_n = rhoa**2. *(3./4.*RPI)**(1./6.) *(12.*RKBOL*t_seri/mH2SO4mol)**0.5 &
     51           & *100.*(2.*VH2SO4mol**(1./3.))**2. !1/(cm3s)
     52      ntot_n=2.0
     53      x_n=1.0
     54    ENDIF
     55  ELSE
     56    ! Use new routine from Anni Maattanen (LATMOS)
     57    csi=0.0   ! no charged nucleation for now
     58    ipr=-1.0  ! dummy value to make sure charged nucleation does not occur
     59    airn=0.0  ! NOT IN USE
     60!   airn=pplay/t_seri/RD/1.E3*RNAVO/RMD ! molec cm-3 (for future use, to be confirmed)
     61    CALL newbinapara(t_seri,rh,rhoa,csi,airn,ipr,jnuc_n,ntot_n,jnuc_i,ntot_i, &
     62                   & x_n,x_i,na_n,na_i,rc_n,rc_i,n_i,kinetic_n,kinetic_i,rhoatres)
     63  ENDIF
     64
     65  ! convert jnuc_n from particles/cm3/s to kg(H2SO4)/kgA/s
     66  nucl_rate=jnuc_n*ntot_n*x_n*mH2SO4mol/(pplay/t_seri/RD/1.E6)
    4567
    4668END SUBROUTINE nucleation_rate
    … …  
    5577  IMPLICIT NONE
    5678
    57   ! input variables
     79  ! input variable
    5880  REAL nucl_rate
    5981  REAL ntot ! total number of molecules in the critical cluster
    60   REAL x    ! molefraction of H2SO4 in the critical cluster
     82  REAL x    ! mole raction of H2SO4 in the critical cluster
    6183  REAL dt
    6284  REAL Vbin(nbtr_bin)
    6385
    64   ! output variables
     86  ! output variable
    6587  REAL tr_seri(nbtr)
    6688
    67   ! local variables
     89  ! local variable
    6890  INTEGER k
    6991  REAL Vnew
    … …  
    7799  DO k=1, nbtr_bin
    78100  ! CK 20160531: bug fix for first bin
    79     IF (k.LE.(nbtr_bin-1)) THEN
     101    IF (k.LE.nbtr_bin-1) THEN
    80102      IF (Vbin(k).LE.Vnew.AND.Vnew.LT.Vbin(k+1)) THEN
    81103        ff(k)= Vbin(k)/Vnew*(Vbin(k+1)-Vnew)/(Vbin(k+1)-Vbin(k))
    … …  
    132154
    133155  REAL :: pt,t     !temperature in K (190.15-300.15K)
    134   REAL :: prh,rh    !saturatio ratio of water (0.0001-1)
    135   REAL,intent(in) :: rhoa_in    !sulfuric acid concentration in 1/cm3 (10^4-10^11 1/cm3)
    136   REAL,intent(out) :: jnuc    !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s)
    137   REAL,intent(out) :: ntot !total number of molecules in the critical cluster (ntot>4)
    138   REAL,intent(out) :: x    ! molefraction of H2SO4 in the critical cluster       
    139   REAL,intent(out) :: rc    !radius of the critical cluster in nm     
    140   REAL :: rhotres    ! treshold concentration of h2so4 (1/cm^3)
     156  REAL :: prh,rh    !saturation ratio of water (0.0001-1)
     157  REAL,INTENT(IN) :: rhoa_in    !sulfuric acid concentration in 1/cm3 (10^4-10^11 1/cm3)
     158  REAL,INTENT(OUT) :: jnuc    !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s)
     159  REAL,INTENT(OUT) :: ntot !total number of molecules in the critical cluster (ntot>4)
     160  REAL,INTENT(OUT) :: x    ! mole fraction of H2SO4 in the critical cluster       
     161  REAL,INTENT(OUT) :: rc    !radius of the critical cluster in nm     
     162  REAL :: rhotres    ! threshold concentration of h2so4 (1/cm^3)
    141163                     ! which produces nucleation rate   1/(cm^3 s) as a function of rh and t
    142164  REAL rhoa
    143165
    144 ! CK: use intermediate variables to avoid overwriting
     166! CK: use intermediate variable to avoid overwriting
    145167  t=pt
    146168  rh=prh
    … …  
    178200  ENDIF
    179201
    180   x=  0.7409967177282139 - 0.002663785665140117*t + 0.002010478847383187*Log(rh)  &
    181        & - 0.0001832894131464668*t*Log(rh) + 0.001574072538464286*Log(rh)**2      &
    182        & - 0.00001790589121766952*t*Log(rh)**2 + 0.0001844027436573778*Log(rh)**3 &
    183        & -  1.503452308794887e-6*t*Log(rh)**3 - 0.003499978417957668*Log(rhoa)    &
    184        & + 0.0000504021689382576*t*Log(rhoa)
     202  x=  0.7409967177282139 - 0.002663785665140117*t + 0.002010478847383187*LOG(rh)  &
     203       & - 0.0001832894131464668*t*LOG(rh) + 0.001574072538464286*LOG(rh)**2      &
     204       & - 0.00001790589121766952*t*LOG(rh)**2 + 0.0001844027436573778*LOG(rh)**3 &
     205       & -  1.503452308794887E-6*t*LOG(rh)**3 - 0.003499978417957668*LOG(rhoa)    &
     206       & + 0.0000504021689382576*t*LOG(rhoa)
    185207
    186208  jnuc= 0.1430901615568665 + 2.219563673425199*t - 0.02739106114964264*t**2 +  &
    187209       &  0.00007228107239317088*t**3 + 5.91822263375044/x +                   &
    188        &  0.1174886643003278*Log(rh) + 0.4625315047693772*t*Log(rh) -          &
    189        &  0.01180591129059253*t**2*Log(rh) +                                   &
    190        &  0.0000404196487152575*t**3*Log(rh) + (15.79628615047088*Log(rh))/x - &
    191        &  0.215553951893509*Log(rh)**2 - 0.0810269192332194*t*Log(rh)**2 +     &
    192        &  0.001435808434184642*t**2*Log(rh)**2 -                               &
    193        &  4.775796947178588e-6*t**3*Log(rh)**2 -                               &
    194        &  (2.912974063702185*Log(rh)**2)/x - 3.588557942822751*Log(rh)**3 +    &
    195        &  0.04950795302831703*t*Log(rh)**3 -                                   &
    196        &  0.0002138195118737068*t**2*Log(rh)**3 +                              &
    197        &  3.108005107949533e-7*t**3*Log(rh)**3 -                               &
    198        &  (0.02933332747098296*Log(rh)**3)/x +                                 &
    199        &  1.145983818561277*Log(rhoa) -                                        &
    200        &  0.6007956227856778*t*Log(rhoa) +                                     &
    201        &  0.00864244733283759*t**2*Log(rhoa) -                                 &
    202        &  0.00002289467254710888*t**3*Log(rhoa) -                              &
    203        &  (8.44984513869014*Log(rhoa))/x +                                     &
    204        &  2.158548369286559*Log(rh)*Log(rhoa) +                                &
    205        &  0.0808121412840917*t*Log(rh)*Log(rhoa) -                             &
    206        &  0.0004073815255395214*t**2*Log(rh)*Log(rhoa) -                       &
    207        &  4.019572560156515e-7*t**3*Log(rh)*Log(rhoa) +                        &
    208        &  (0.7213255852557236*Log(rh)*Log(rhoa))/x +                           &
    209        &  1.62409850488771*Log(rh)**2*Log(rhoa) -                              &
    210        &  0.01601062035325362*t*Log(rh)**2*Log(rhoa) +                         &
    211        &  0.00003771238979714162*t**2*Log(rh)**2*Log(rhoa) +                   &
    212        &  3.217942606371182e-8*t**3*Log(rh)**2*Log(rhoa) -                     &
    213        &  (0.01132550810022116*Log(rh)**2*Log(rhoa))/x +                       &
    214        &  9.71681713056504*Log(rhoa)**2 -                                      &
    215        &  0.1150478558347306*t*Log(rhoa)**2 +                                  &
    216        &  0.0001570982486038294*t**2*Log(rhoa)**2 +                            &
    217        &  4.009144680125015e-7*t**3*Log(rhoa)**2 +                             &
    218        &  (0.7118597859976135*Log(rhoa)**2)/x -                                &
    219        &  1.056105824379897*Log(rh)*Log(rhoa)**2 +                             &
    220        &  0.00903377584628419*t*Log(rh)*Log(rhoa)**2 -                         &
    221        &  0.00001984167387090606*t**2*Log(rh)*Log(rhoa)**2 +                   &
    222        &  2.460478196482179e-8*t**3*Log(rh)*Log(rhoa)**2 -                     &
    223        &  (0.05790872906645181*Log(rh)*Log(rhoa)**2)/x -                       &
    224        &  0.1487119673397459*Log(rhoa)**3 +                                    &
    225        &  0.002835082097822667*t*Log(rhoa)**3 -                                &
    226        &  9.24618825471694e-6*t**2*Log(rhoa)**3 +                              &
    227        &  5.004267665960894e-9*t**3*Log(rhoa)**3 -                             &
    228        &  (0.01270805101481648*Log(rhoa)**3)/x
    229   jnuc=exp(jnuc) !1/(cm3s)
    230 
    231   ntot =-0.002954125078716302 - 0.0976834264241286*t + 0.001024847927067835*t**2 - 2.186459697726116e-6*t**3 -    &
    232        &   0.1017165718716887/x - 0.002050640345231486*Log(rh) - 0.007585041382707174*t*Log(rh) +                 &
    233        &   0.0001926539658089536*t**2*Log(rh) - 6.70429719683894e-7*t**3*Log(rh) -                                &
    234        &   (0.2557744774673163*Log(rh))/x + 0.003223076552477191*Log(rh)**2 + 0.000852636632240633*t*Log(rh)**2 - &
    235        &   0.00001547571354871789*t**2*Log(rh)**2 + 5.666608424980593e-8*t**3*Log(rh)**2 +                        &
    236        &   (0.03384437400744206*Log(rh)**2)/x + 0.04743226764572505*Log(rh)**3 -                                  &
    237        &   0.0006251042204583412*t*Log(rh)**3 + 2.650663328519478e-6*t**2*Log(rh)**3 -                            &
    238        &   3.674710848763778e-9*t**3*Log(rh)**3 - (0.0002672510825259393*Log(rh)**3)/x -                          &
    239        &   0.01252108546759328*Log(rhoa) + 0.005806550506277202*t*Log(rhoa) -                                     &
    240        &   0.0001016735312443444*t**2*Log(rhoa) + 2.881946187214505e-7*t**3*Log(rhoa) +                           &
    241        &   (0.0942243379396279*Log(rhoa))/x - 0.0385459592773097*Log(rh)*Log(rhoa) -                              &
    242        &   0.0006723156277391984*t*Log(rh)*Log(rhoa) + 2.602884877659698e-6*t**2*Log(rh)*Log(rhoa) +              &
    243        &   1.194163699688297e-8*t**3*Log(rh)*Log(rhoa) - (0.00851515345806281*Log(rh)*Log(rhoa))/x -              &
    244        &   0.01837488495738111*Log(rh)**2*Log(rhoa) + 0.0001720723574407498*t*Log(rh)**2*Log(rhoa) -              &
    245        &   3.717657974086814e-7*t**2*Log(rh)**2*Log(rhoa) -                                                       &
    246        &   5.148746022615196e-10*t**3*Log(rh)**2*Log(rhoa) +                                                      &
    247        &   (0.0002686602132926594*Log(rh)**2*Log(rhoa))/x - 0.06199739728812199*Log(rhoa)**2 +                    &
    248        &   0.000906958053583576*t*Log(rhoa)**2 - 9.11727926129757e-7*t**2*Log(rhoa)**2 -                          &
    249        &   5.367963396508457e-9*t**3*Log(rhoa)**2 - (0.007742343393937707*Log(rhoa)**2)/x +                       &
    250        &   0.0121827103101659*Log(rh)*Log(rhoa)**2 - 0.0001066499571188091*t*Log(rh)*Log(rhoa)**2 +               &
    251        &   2.534598655067518e-7*t**2*Log(rh)*Log(rhoa)**2 -                                                       &
    252        &   3.635186504599571e-10*t**3*Log(rh)*Log(rhoa)**2 +                                                      &
    253        &   (0.0006100650851863252*Log(rh)*Log(rhoa)**2)/x + 0.0003201836700403512*Log(rhoa)**3 -                  &
    254        &   0.0000174761713262546*t*Log(rhoa)**3 + 6.065037668052182e-8*t**2*Log(rhoa)**3 -                        &
    255        &   1.421771723004557e-11*t**3*Log(rhoa)**3 + (0.0001357509859501723*Log(rhoa)**3)/x
    256   ntot=exp(ntot)
    257 
    258   rc=exp(-1.6524245+0.42316402*x+0.33466487*log(ntot)) !nm
    259 
    260   IF (jnuc < 1.e-7) THEN
    261 !     print *,'Warning (ilon=',ilon,'ilev=',ilev'): nucleation rate < 1e-7/cm3s, using 0.0/cm3s,'
     210       &  0.1174886643003278*LOG(rh) + 0.4625315047693772*t*LOG(rh) -          &
     211       &  0.01180591129059253*t**2*LOG(rh) +                                   &
     212       &  0.0000404196487152575*t**3*LOG(rh) + (15.79628615047088*LOG(rh))/x - &
     213       &  0.215553951893509*LOG(rh)**2 - 0.0810269192332194*t*LOG(rh)**2 +     &
     214       &  0.001435808434184642*t**2*LOG(rh)**2 -                               &
     215       &  4.775796947178588E-6*t**3*LOG(rh)**2 -                               &
     216       &  (2.912974063702185*LOG(rh)**2)/x - 3.588557942822751*LOG(rh)**3 +    &
     217       &  0.04950795302831703*t*LOG(rh)**3 -                                   &
     218       &  0.0002138195118737068*t**2*LOG(rh)**3 +                              &
     219       &  3.108005107949533E-7*t**3*LOG(rh)**3 -                               &
     220       &  (0.02933332747098296*LOG(rh)**3)/x +                                 &
     221       &  1.145983818561277*LOG(rhoa) -                                        &
     222       &  0.6007956227856778*t*LOG(rhoa) +                                     &
     223       &  0.00864244733283759*t**2*LOG(rhoa) -                                 &
     224       &  0.00002289467254710888*t**3*LOG(rhoa) -                              &
     225       &  (8.44984513869014*LOG(rhoa))/x +                                     &
     226       &  2.158548369286559*LOG(rh)*LOG(rhoa) +                                &
     227       &  0.0808121412840917*t*LOG(rh)*LOG(rhoa) -                             &
     228       &  0.0004073815255395214*t**2*LOG(rh)*LOG(rhoa) -                       &
     229       &  4.019572560156515E-7*t**3*LOG(rh)*LOG(rhoa) +                        &
     230       &  (0.7213255852557236*LOG(rh)*LOG(rhoa))/x +                           &
     231       &  1.62409850488771*LOG(rh)**2*LOG(rhoa) -                              &
     232       &  0.01601062035325362*t*LOG(rh)**2*LOG(rhoa) +                         &
     233       &  0.00003771238979714162*t**2*LOG(rh)**2*LOG(rhoa) +                   &
     234       &  3.217942606371182E-8*t**3*LOG(rh)**2*LOG(rhoa) -                     &
     235       &  (0.01132550810022116*LOG(rh)**2*LOG(rhoa))/x +                       &
     236       &  9.71681713056504*LOG(rhoa)**2 -                                      &
     237       &  0.1150478558347306*t*LOG(rhoa)**2 +                                  &
     238       &  0.0001570982486038294*t**2*LOG(rhoa)**2 +                            &
     239       &  4.009144680125015E-7*t**3*LOG(rhoa)**2 +                             &
     240       &  (0.7118597859976135*LOG(rhoa)**2)/x -                                &
     241       &  1.056105824379897*LOG(rh)*LOG(rhoa)**2 +                             &
     242       &  0.00903377584628419*t*LOG(rh)*LOG(rhoa)**2 -                         &
     243       &  0.00001984167387090606*t**2*LOG(rh)*LOG(rhoa)**2 +                   &
     244       &  2.460478196482179E-8*t**3*LOG(rh)*LOG(rhoa)**2 -                     &
     245       &  (0.05790872906645181*LOG(rh)*LOG(rhoa)**2)/x -                       &
     246       &  0.1487119673397459*LOG(rhoa)**3 +                                    &
     247       &  0.002835082097822667*t*LOG(rhoa)**3 -                                &
     248       &  9.24618825471694E-6*t**2*LOG(rhoa)**3 +                              &
     249       &  5.004267665960894E-9*t**3*LOG(rhoa)**3 -                             &
     250       &  (0.01270805101481648*LOG(rhoa)**3)/x
     251  jnuc=EXP(jnuc) !1/(cm3s)
     252
     253  ntot =-0.002954125078716302 - 0.0976834264241286*t + 0.001024847927067835*t**2 - 2.186459697726116E-6*t**3 -    &
     254       &   0.1017165718716887/x - 0.002050640345231486*LOG(rh) - 0.007585041382707174*t*LOG(rh) +                 &
     255       &   0.0001926539658089536*t**2*LOG(rh) - 6.70429719683894E-7*t**3*LOG(rh) -                                &
     256       &   (0.2557744774673163*LOG(rh))/x + 0.003223076552477191*LOG(rh)**2 + 0.000852636632240633*t*LOG(rh)**2 - &
     257       &   0.00001547571354871789*t**2*LOG(rh)**2 + 5.666608424980593E-8*t**3*LOG(rh)**2 +                        &
     258       &   (0.03384437400744206*LOG(rh)**2)/x + 0.04743226764572505*LOG(rh)**3 -                                  &
     259       &   0.0006251042204583412*t*LOG(rh)**3 + 2.650663328519478E-6*t**2*LOG(rh)**3 -                            &
     260       &   3.674710848763778E-9*t**3*LOG(rh)**3 - (0.0002672510825259393*LOG(rh)**3)/x -                          &
     261       &   0.01252108546759328*LOG(rhoa) + 0.005806550506277202*t*LOG(rhoa) -                                     &
     262       &   0.0001016735312443444*t**2*LOG(rhoa) + 2.881946187214505E-7*t**3*LOG(rhoa) +                           &
     263       &   (0.0942243379396279*LOG(rhoa))/x - 0.0385459592773097*LOG(rh)*LOG(rhoa) -                              &
     264       &   0.0006723156277391984*t*LOG(rh)*LOG(rhoa) + 2.602884877659698E-6*t**2*LOG(rh)*LOG(rhoa) +              &
     265       &   1.194163699688297E-8*t**3*LOG(rh)*LOG(rhoa) - (0.00851515345806281*LOG(rh)*LOG(rhoa))/x -              &
     266       &   0.01837488495738111*LOG(rh)**2*LOG(rhoa) + 0.0001720723574407498*t*LOG(rh)**2*LOG(rhoa) -              &
     267       &   3.717657974086814E-7*t**2*LOG(rh)**2*LOG(rhoa) -                                                       &
     268       &   5.148746022615196E-10*t**3*LOG(rh)**2*LOG(rhoa) +                                                      &
     269       &   (0.0002686602132926594*LOG(rh)**2*LOG(rhoa))/x - 0.06199739728812199*LOG(rhoa)**2 +                    &
     270       &   0.000906958053583576*t*LOG(rhoa)**2 - 9.11727926129757E-7*t**2*LOG(rhoa)**2 -                          &
     271       &   5.367963396508457E-9*t**3*LOG(rhoa)**2 - (0.007742343393937707*LOG(rhoa)**2)/x +                       &
     272       &   0.0121827103101659*LOG(rh)*LOG(rhoa)**2 - 0.0001066499571188091*t*LOG(rh)*LOG(rhoa)**2 +               &
     273       &   2.534598655067518E-7*t**2*LOG(rh)*LOG(rhoa)**2 -                                                       &
     274       &   3.635186504599571E-10*t**3*LOG(rh)*LOG(rhoa)**2 +                                                      &
     275       &   (0.0006100650851863252*LOG(rh)*LOG(rhoa)**2)/x + 0.0003201836700403512*LOG(rhoa)**3 -                  &
     276       &   0.0000174761713262546*t*LOG(rhoa)**3 + 6.065037668052182E-8*t**2*LOG(rhoa)**3 -                        &
     277       &   1.421771723004557E-11*t**3*LOG(rhoa)**3 + (0.0001357509859501723*LOG(rhoa)**3)/x
     278  ntot=EXP(ntot)
     279
     280  rc=EXP(-1.6524245+0.42316402*x+0.33466487*LOG(ntot)) !nm
     281
     282  IF (jnuc < 1.E-7) THEN
     283!     print *,'Warning (ilon=',ilon,'ilev=',ilev'): nucleation rate < 1E-7/cm3s, using 0.0/cm3s,'
    262284     jnuc=0.0
    263285  ENDIF
    … …  
    269291  ENDIF
    270292
    271   rhotres=exp( -279.2430007512709 + 11.73439886096903*rh + 22700.92970508331/t &
     293  rhotres=EXP( -279.2430007512709 + 11.73439886096903*rh + 22700.92970508331/t &
    272294       & - (1088.644983466801*rh)/t + 1.144362942094912*t                      &
    273295       & - 0.03023314602163684*rh*t - 0.001302541390154324*t**2                &
    274        & - 6.386965238433532*Log(rh) + (854.980361026715*Log(rh))/t            &
    275        & + 0.00879662256826497*t*Log(rh)) !1/cm3
     296       & - 6.386965238433532*LOG(rh) + (854.980361026715*LOG(rh))/t            &
     297       & + 0.00879662256826497*t*LOG(rh)) !1/cm3
    276298
    277299  RETURN
    … …  
    279301END SUBROUTINE binapara
    280302
     303!---------------------------------------------------------------------------------------------------
     304
     305SUBROUTINE newbinapara(t,satrat,rhoa,csi,airn,ipr,jnuc_n_real,ntot_n_real,jnuc_i_real,ntot_i_real,        &
     306                   &   x_n_real,x_i_real,na_n_real,na_i_real,rc_n_real,rc_i_real,n_i_real,                &
     307                   &   kinetic_n,kinetic_i,rhoatres_real)
     308
     309  !    Fortran 90 subroutine newbinapara
     310  !
     311  !    Calculates parametrized values for neutral and ion-induced sulfuric acid-water particle formation rate
     312  !    of critical clusters,
     313  !    number of particle in the critical clusters, the radii of the critical clusters
     314  !    in H2O-H2SO4-ion system if temperature, saturation ratio of water, sulfuric acid concentration,
     315  !    and, optionally, either condensation sink due to pre-existing particle and ion pair production rate,
     316  !    or atmospheric concentration of negative ions are given.
     317  !
     318  !    The code calculates also the kinetic limit and the particle formation rate
     319  !    above this limit (in which case we set ntot=1 and na=1)
     320  !
     321  !    Copyright (C)2018 Määttänen et al. 2018
     322  !   
     323  !    anni.maattanen@latmos.ipsl.fr
     324  !    joonas.merikanto@fmi.fi
     325  !    hanna.vehkamaki@helsinki.fi
     326  !
     327  !    References
     328  !    A. Määttänen, J. Merikanto, H. Henschel, J. Duplissy, R. Makkonen,
     329  !    I. K. Ortega and H. Vehkamäki (2018), New parameterizations for
     330  !    neutral and ion-induced sulfuric acid-water particle formation in
     331  !    nucleation and kinetic regimes, J. Geophys. Res. Atmos., 122, doi:10.1002/2017JD027429.
     332  !
     333  !    Brasseur, G., and A.  Chatel (1983),  paper  presented  at  the  9th  Annual  Meeting  of  the 
     334  !    European Geophysical Society, Leeds, Great Britain, August 1982.
     335  ! 
     336  !    Dunne, Eimear M., et al.(2016), Global atmospheric particle formation from CERN CLOUD measurements,
     337  !    Science 354.6316, 1119-1124.   
     338  !
     339
     340  USE aerophys
     341  USE YOMCST, ONLY : RPI, RKBOL
     342
     343  IMPLICIT NONE
     344
     345  !----------------------------------------------------
     346 
     347  !Global intent in
     348  REAL,INTENT(IN) :: t         ! temperature in K
     349  REAL,INTENT(IN) :: satrat    ! saturatio ratio of water (between zero and 1)
     350  REAL,INTENT(IN) :: rhoa      ! sulfuric acid concentration in 1/cm3
     351  REAL,INTENT(IN) :: csi       ! Ion condensation sink (s-1)
     352  REAL,INTENT(IN) :: airn      ! Air molecule concentration in (cm-3)
     353  REAL,INTENT(IN) :: ipr       ! Ion pair production rate (cm-3 s-1)
     354  !Global intent out
     355  REAL,INTENT(OUT) :: jnuc_n_real   ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
     356  REAL,INTENT(OUT) :: ntot_n_real   ! total number of molecules in the neutral critical cluster
     357  REAL,INTENT(OUT) :: jnuc_i_real   ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
     358  REAL,INTENT(OUT) :: ntot_i_real   ! total number of molecules in the charged critical cluster
     359  REAL,INTENT(OUT) :: x_n_real      ! mole fraction of H2SO4 in the neutral critical cluster
     360  REAL,INTENT(OUT) :: x_i_real      ! mole fraction of H2SO4 in the charged critical cluster
     361                                           ! (note that x_n=x_i in nucleation regime)
     362  REAL,INTENT(OUT) :: na_n_real     ! sulfuric acid molecules in the neutral critical cluster
     363  REAL,INTENT(OUT) :: na_i_real     ! sulfuric molecules in the charged critical cluster
     364  REAL,INTENT(OUT) :: rc_n_real     ! radius of the charged critical cluster in nm
     365  REAL,INTENT(OUT) :: rc_i_real     ! radius of the charged critical cluster in nm
     366  REAL,INTENT(OUT) :: n_i_real      ! number of ion pairs in air (cm-3)
     367  REAL,INTENT(OUT) :: rhoatres_real ! threshold concentration of H2SO4 (1/cm^3) for neutral kinetic nucleation
     368  LOGICAL,INTENT(OUT)  :: kinetic_n        ! true if kinetic neutral nucleation
     369  LOGICAL,INTENT(OUT)  :: kinetic_i        ! true if kinetic ion-induced nucleation
     370
     371  ! Local
     372  DOUBLE PRECISION :: jnuc_n      ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
     373  DOUBLE PRECISION :: ntot_n      ! total number of molecules in the neutral critical cluster
     374  DOUBLE PRECISION :: jnuc_i      ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
     375  DOUBLE PRECISION :: ntot_i      ! total number of molecules in the charged critical cluster
     376  DOUBLE PRECISION :: x_n         ! mole fraction of H2SO4 in the neutral critical cluster
     377  DOUBLE PRECISION :: x_i         ! mole fraction of H2SO4 in the charged critical cluster
     378                                              ! (note that x_n=x_i in nucleation regime)
     379  DOUBLE PRECISION :: na_n        ! sulfuric acid molecules in the neutral critical cluster
     380  DOUBLE PRECISION :: na_i        ! sulfuric molecules in the charged critical cluster
     381  DOUBLE PRECISION :: rc_n        ! radius of the charged critical cluster in nm
     382  DOUBLE PRECISION :: rc_i        ! radius of the charged critical cluster in nm
     383  DOUBLE PRECISION :: n_i         ! number of ion pairs in air (cm-3)
     384  DOUBLE PRECISION :: rhoatres    ! threshold concentration of H2SO4 (1/cm^3) for neutral kinetic nucleation
     385  DOUBLE PRECISION :: x           ! mole fraction of H2SO4 in the critical cluster
     386  DOUBLE PRECISION :: satratln    ! bounded water saturation ratio for neutral case (between 5.E-6 - 1.0)
     387  DOUBLE PRECISION :: satratli    ! bounded water saturation ratio for ion-induced case (between 1.E-7 - 0.95)
     388  DOUBLE PRECISION :: rhoaln      ! bounded concentration of h2so4 for neutral case (between 10^10 - 10^19 m-3)
     389  DOUBLE PRECISION :: rhoali      ! bounded concentration of h2so4 for ion-induced case (between 10^10 - 10^22 m-3)
     390  DOUBLE PRECISION :: tln         ! bounded temperature for neutral case (between 165-400 K)
     391  DOUBLE PRECISION :: tli         ! bounded temperature for ion-induced case (195-400 K)
     392  DOUBLE PRECISION :: kinrhotresn ! threshold sulfuric acid for neutral kinetic nucleation   
     393  DOUBLE PRECISION :: kinrhotresi ! threshold sulfuric acid for ion-induced kinetic nucleation
     394  DOUBLE PRECISION :: jnuc_i1     ! Ion-induced rate for n_i=1 cm-3
     395  DOUBLE PRECISION :: xloss       ! Ion loss rate
     396  DOUBLE PRECISION :: recomb      ! Ion-ion recombination rate
     397
     398  !--- 0) Initializations:
     399
     400  kinetic_n=.FALSE.
     401  kinetic_i=.FALSE.
     402  jnuc_n=0.0
     403  jnuc_i=0.0
     404  ntot_n=0.0
     405  ntot_i=0.0
     406  na_n=0.0
     407  na_i=0.0
     408  rc_n=0.0
     409  rc_i=0.0
     410  x=0.0
     411  x_n=0.0
     412  x_i=0.0
     413  satratln=satrat
     414  satratli=satrat
     415  rhoaln=rhoa
     416  rhoali=rhoa
     417  tln=t
     418  tli=t
     419  n_i=0.0
     420
     421  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     422
     423  !Boundary values according to parameterization limits   
     424
     425  !Temperature bounds
     426  IF (t.LE.165.) THEN
     427!     print *,'Warning: temperature < 165.0 K, using 165.0 K in neutral nucleation calculation'
     428     tln=165.0
     429  ENDIF
     430  IF (t.LE.195.) THEN
     431!     print *,'Warning: temperature < 195.0 K, using 195.0 K in ion-induced nucleation calculation'
     432     tli=195.0
     433  ENDIF
     434  IF (t.GE.400.) THEN
     435!     print *,'Warning: temperature > 400. K, using 400. K in nucleation calculations'
     436     tln=400.
     437     tli=400.
     438  ENDIF
     439 
     440  ! Saturation ratio bounds
     441  IF (satrat.LT.1.E-7) THEN
     442!     print *,'Warning: saturation ratio of water < 1.E-7, using 1.E-7 in ion-induced nucleation calculation'
     443     satratli=1.E-7
     444  ENDIF
     445  IF (satrat.LT.1.E-5) THEN
     446!     print *,'Warning: saturation ratio of water < 1.E-5, using 1.E-5 in neutral nucleation calculation'
     447     satratln=1.E-5
     448  ENDIF
     449  IF (satrat.GT.0.95) THEN
     450!     print *,'Warning: saturation ratio of water > 0.95, using 0.95 in ion-induced nucleation calculation'
     451     satratli=0.95
     452  ENDIF
     453  IF (satrat.GT.1.0) THEN
     454!     print *,'Warning: saturation ratio of water > 1 using 1 in neutral nucleation calculation'
     455     satratln=1.0
     456  ENDIF
     457 
     458  ! Sulfuric acid concentration bounds
     459  IF (rhoa.LE.1.E4) THEN
     460!     print *,'Warning: sulfuric acid < 1e4 1/cm3, using 1e4 1/cm3 in nucleation calculation'
     461     rhoaln=1.E4
     462     rhoali=1.E4
     463  ENDIF
     464  IF (rhoa.GT.1.E13) THEN
     465!     print *,'Warning: sulfuric acid > 1e13 1/cm3, using 1e13 1/cm3 in neutral nucleation calculation'
     466     rhoaln=1.E13
     467  ENDIF
     468  IF (rhoa.GT.1.E16) THEN
     469!     print *,'Warning: sulfuric acid concentration > 1e16 1/cm3, using 1e16 1/cm3 in ion-induced nucleation calculation'
     470     rhoali=1.E16
     471  ENDIF
     472 
     473  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     474 
     475  !Critical cluster composition (valid for both cases, bounds not used here)
     476  x_n=  7.9036365428891719E-1 - 2.8414059650092153E-3*tln + 1.4976802556584141E-2*LOG(satratln)  &
     477       & - 2.4511581740839115E-4*tln*LOG(satratln) + 3.4319869471066424E-3 *LOG(satratln)**2     &
     478       & - 2.8799393617748428E-5*tln*LOG(satratln)**2 + 3.0174314126331765E-4*LOG(satratln)**3   &
     479       & - 2.2673492408841294E-6*tln*LOG(satratln)**3 - 4.3948464567032377E-3*LOG(rhoaln)        &
     480       & + 5.3305314722492146E-5*tln*LOG(rhoaln)
     481  x_i=  7.9036365428891719E-1 - 2.8414059650092153E-3*tli + 1.4976802556584141E-2*LOG(satratli)  &
     482       & - 2.4511581740839115E-4*tli*LOG(satratli) + 3.4319869471066424E-3 *LOG(satratli)**2     &
     483       & - 2.8799393617748428E-5*tli*LOG(satratli)**2 + 3.0174314126331765E-4*LOG(satratli)**3   &
     484       & - 2.2673492408841294E-6*tli*LOG(satratli)**3 - 4.3948464567032377E-3*LOG(rhoali)        &
     485       & + 5.3305314722492146E-5*tli*LOG(rhoali)
     486       
     487  x_n=MIN(MAX(x_n,1.E-30),1.)
     488  x_i=MIN(MAX(x_i,1.E-30),1.)
     489 
     490  !Neutral nucleation
     491 
     492  !Kinetic limit check
     493  IF (satratln .GE. 1.E-2 .AND. satratln .LE. 1.) THEN
     494     kinrhotresn=EXP(7.8920778706888086E+1 + 7.3665492897447082*satratln - 1.2420166571163805E+4/tln &
     495          & + (-6.1831234251470971E+2*satratln)/tln - 2.4501159970109945E-2*tln                      &
     496          & -1.3463066443605762E-2*satratln*tln + 8.3736373989909194E-06*tln**2                      &
     497          & -1.4673887785408892*LOG(satratln) + (-3.2141890006517094E+1*LOG(satratln))/tln           &
     498          & + 2.7137429081917556E-3*tln*LOG(satratln)) !1/cm3     
     499     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
     500  ENDIF
     501
     502  IF (satratln .GE. 1.E-4  .AND. satratln .LT. 1.E-2) THEN     
     503     kinrhotresn=EXP(7.9074383049843647E+1 - 2.8746005462158347E+1*satratln - 1.2070272068458380E+4/tln &
     504          & + (-5.9205040320056632E+3*satratln)/tln - 2.4800372593452726E-2*tln                         &
     505          & -4.3983007681295948E-2*satratln*tln + 2.5943854791342071E-5*tln**2                          &
     506          & -2.3141363245211317*LOG(satratln) + (9.9186787997857735E+1*LOG(satratln))/tln               &
     507          & + 5.6819382556144681E-3*tln*LOG(satratln)) !1/cm3
     508     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
     509  ENDIF
     510
     511  IF (satratln .GE. 5.E-6  .AND. satratln .LT. 1.E-4) THEN
     512     kinrhotresn=EXP(8.5599712000361677E+1 + 2.7335119660796581E+3*satratln - 1.1842350246291651E+4/tln &
     513          & + (-1.2439843468881438E+6*satratln)/tln - 5.4536964974944230E-2*tln                         &
     514          & + 5.0886987425326087*satratln*tln + 7.1964722655507067E-5*tln**2                            &
     515          & -2.4472627526306372*LOG(satratln) + (1.7561478001423779E+2*LOG(satratln))/tln               &
     516          & + 6.2640132818141811E-3*tln*LOG(satratln)) !1/cm3
     517     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
     518  ENDIF
     519 
     520  IF (kinetic_n) THEN   
     521     ! Dimer formation rate
     522     jnuc_n=1.E6*(2.*0.3E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))/2.*SQRT(t)*rhoa**2.
     523!     jnuc_n=1.E6*(2.*0.3E-9)**2.*SQRT(8.*3.141593*1.38E-23*(1./(1.661E-27*98.07)+1./(1.661E-27*98.07)))/2.*SQRT(t)*rhoa**2.
     524     ntot_n=1. !set to 1
     525     na_n=1.   ! The critical cluster contains one molecules but the produced cluster contains 2 molecules
     526     x_n=na_n/ntot_n  ! so also set this to 1
     527     rc_n=0.3E-9
     528  ELSE
     529     jnuc_n= 2.1361182605986115E-1 + 3.3827029855551838*tln -3.2423555796175563E-2*tln**2 +         &
     530          &  7.0120069477221989E-5*tln**3 +8.0286874752695141/x_n +                                 &
     531          &  -2.6939840579762231E-1*LOG(satratln) +1.6079879299099518*tln*LOG(satratln) +           &
     532          &  -1.9667486968141933E-2*tln**2*LOG(satratln) +                                          &
     533          &  5.5244755979770844E-5*tln**3*LOG(satratln) + (7.8884704837892468*LOG(satratln))/x_n +  &
     534          &  4.6374659198909596*LOG(satratln)**2 - 8.2002809894792153E-2*tln*LOG(satratln)**2 +     &
     535          &  8.5077424451172196E-4*tln**2*LOG(satratln)**2 +                                        &
     536          &  -2.6518510168987462E-6*tln**3*LOG(satratln)**2 +                                       &
     537          &  (-1.4625482500575278*LOG(satratln)**2)/x_n - 5.2413002989192037E-1*LOG(satratln)**3 +  &
     538          &  5.2755117653715865E-3*tln*LOG(satratln)**3 +                                           &
     539          &  -2.9491061332113830E-6*tln**2*LOG(satratln)**3 +                                       &
     540          &  -2.4815454194486752E-8*tln**3*LOG(satratln)**3 +                                       &
     541          &  (-5.2663760117394626E-2*LOG(satratln)**3)/x_n +                                        &
     542          &  1.6496664658266762*LOG(rhoaln) +                                                       &
     543          &  -8.0809397859218401E-1*tln*LOG(rhoaln) +                                               &
     544          &  8.9302927091946642E-3*tln**2*LOG(rhoaln) +                                             &
     545          &  -1.9583649496497497E-5*tln**3*LOG(rhoaln) +                                            &
     546          &  (-8.9505572676891685*LOG(rhoaln))/x_n +                                                &
     547          &  -3.0025283601622881E+1*LOG(satratln)*LOG(rhoaln) +                                     &
     548          &  3.0783365644763633E-1*tln*LOG(satratln)*LOG(rhoaln) +                                  &
     549          &  -7.4521756337984706E-4*tln**2*LOG(satratln)*LOG(rhoaln) +                              &
     550          &  -5.7651433870681853E-7*tln**3*LOG(satratln)*LOG(rhoaln) +                              &
     551          &  (1.2872868529673207*LOG(satratln)*LOG(rhoaln))/x_n +                                   &
     552          &  -6.1739867501526535E-1*LOG(satratln)**2*LOG(rhoaln) +                                  &
     553          &  7.2347385705333975E-3*tln*LOG(satratln)**2*LOG(rhoaln) +                               &
     554          &  -3.0640494530822439E-5*tln**2*LOG(satratln)**2*LOG(rhoaln) +                           &
     555          &  6.5944609194346214E-8*tln**3*LOG(satratln)**2*LOG(rhoaln) +                            &
     556          &  (-2.8681650332461055E-2*LOG(satratln)**2*LOG(rhoaln))/x_n +                            &
     557          &  6.5213802375160306*LOG(rhoaln)**2 +                                                    &
     558          &  -4.7907162004793016E-2*tln*LOG(rhoaln)**2 +                                            &
     559          &  -1.0727890114215117E-4*tln**2*LOG(rhoaln)**2 +                                         &
     560          &  5.6401818280534507E-7*tln**3*LOG(rhoaln)**2 +                                          &
     561          &  (5.4113070888923009E-1*LOG(rhoaln)**2)/x_n +                                           &
     562          &  5.2062808476476330E-1*LOG(satratln)*LOG(rhoaln)**2 +                                   &
     563          &  -6.0696882500824584E-3*tln*LOG(satratln)*LOG(rhoaln)**2 +                              &
     564          &  2.3851383302608477E-5*tln**2*LOG(satratln)*LOG(rhoaln)**2 +                            &
     565          &  -1.5243837103067096E-8*tln**3*LOG(satratln)*LOG(rhoaln)**2 +                           &
     566          &  (-5.6543192378015687E-2*LOG(satratln)*LOG(rhoaln)**2)/x_n +                            &
     567          &  -1.1630806410696815E-1*LOG(rhoaln)**3 +                                                &
     568          &  1.3806404273119610E-3*tln*LOG(rhoaln)**3 +                                             &
     569          &  -2.0199865087650833E-6*tln**2*LOG(rhoaln)**3 +                                         &
     570          &  -3.0200284885763192E-9*tln**3*LOG(rhoaln)**3 +                                         &
     571          &  (-6.9425267104126316E-3*LOG(rhoaln)**3)/x_n
     572     jnuc_n=EXP(jnuc_n)
     573     
     574     ntot_n =-3.5863435141979573E-3 - 1.0098670235841110E-1*tln + 8.9741268319259721E-4*tln**2 - 1.4855098605195757E-6*tln**3 &
     575          &   - 1.2080330016937095E-1/x_n + 1.1902674923928015E-3*LOG(satratln) - 1.9211358507172177E-2*tln*LOG(satratln) +   &
     576          &   2.4648094311204255E-4*tln**2*LOG(satratln) - 7.5641448594711666E-7*tln**3*LOG(satratln) +                       &
     577          &   (-2.0668639384228818E-02*LOG(satratln))/x_n - 3.7593072011595188E-2*LOG(satratln)**2 +                          &
     578          &   9.0993182774415718E-4 *tln*LOG(satratln)**2 +                                                                   &
     579          &   -9.5698412164297149E-6*tln**2*LOG(satratln)**2 + 3.7163166416110421E-8*tln**3*LOG(satratln)**2 +                &
     580          &   (1.1026579525210847E-2*LOG(satratln)**2)/x_n + 1.1530844115561925E-2 *LOG(satratln)**3 +                        &
     581          &   - 1.8083253906466668E-4 *tln*LOG(satratln)**3 + 8.0213604053330654E-7*tln**2*LOG(satratln)**3 +                 &
     582          &   -8.5797885383051337E-10*tln**3*LOG(satratln)**3 + (1.0243693899717402E-3*LOG(satratln)**3)/x_n +                &
     583          &   -1.7248695296299649E-2*LOG(rhoaln) + 1.1294004162437157E-2*tln*LOG(rhoaln) +                                    &
     584          &   -1.2283640163189278E-4*tln**2*LOG(rhoaln) + 2.7391732258259009E-7*tln**3*LOG(rhoaln) +                          &
     585          &   (6.8505583974029602E-2*LOG(rhoaln))/x_n +2.9750968179523635E-1*LOG(satratln)*LOG(rhoaln) +                      &
     586          &   -3.6681154503992296E-3 *tln*LOG(satratln)*LOG(rhoaln) + 1.0636473034653114E-5*tln**2*LOG(satratln)*LOG(rhoaln)+ &
     587          &   5.8687098466515866E-9*tln**3*LOG(satratln)*LOG(rhoaln) + (-5.2028866094191509E-3*LOG(satratln)*LOG(rhoaln))/x_n+&
     588          &   7.6971988880587231E-4*LOG(satratln)**2*LOG(rhoaln) - 2.4605575820433763E-5*tln*LOG(satratln)**2*LOG(rhoaln) +   &
     589          &   2.3818484400893008E-7*tln**2*LOG(satratln)**2*LOG(rhoaln) +                                                     &
     590          &   -8.8474102392445200E-10*tln**3*LOG(satratln)**2*LOG(rhoaln) +                                                   &
     591          &   (-1.6640566678168968E-4*LOG(satratln)**2*LOG(rhoaln))/x_n - 7.7390093776705471E-2*LOG(rhoaln)**2 +              &
     592          &   5.8220163188828482E-4*tln*LOG(rhoaln)**2 + 1.2291679321523287E-6*tln**2*LOG(rhoaln)**2 +                        &
     593          &   -7.4690997508075749E-9*tln**3*LOG(rhoaln)**2 + (-5.6357941220497648E-3*LOG(rhoaln)**2)/x_n +                    &
     594          &   -4.7170109625089768E-3*LOG(satratln)*LOG(rhoaln)**2 + 6.9828868534370193E-5*tln*LOG(satratln)*LOG(rhoaln)**2 +  &
     595          &   -3.1738912157036403E-7*tln**2*LOG(satratln)*LOG(rhoaln)**2 +                                                    &
     596          &   2.3975538706787416E-10*tln**3*LOG(satratln)*LOG(rhoaln)**2 +                                                    &
     597          &   (4.2304213386288567E-4*LOG(satratln)*LOG(rhoaln)**2)/x_n + 1.3696520973423231E-3*LOG(rhoaln)**3 +               &
     598          &   -1.6863387574788199E-5*tln*LOG(rhoaln)**3 + 2.7959499278844516E-8*tln**2*LOG(rhoaln)**3 +                       &
     599          &   3.9423927013227455E-11*tln**3*LOG(rhoaln)**3 + (8.6136359966337272E-5*LOG(rhoaln)**3)/x_n
     600     ntot_n=EXP(ntot_n)
     601     
     602     rc_n=EXP(-22.378268374023630+0.44462953606125100*x_n+0.33499495707849131*LOG(ntot_n)) !in meters
     603     
     604     na_n=x_n*ntot_n
     605     IF (na_n .LT. 1.) THEN
     606        print *, 'Warning: number of acid molecules < 1 in nucleation regime, setting na_n=1'
     607        na_n=1.0
     608     ENDIF
     609  ENDIF
     610 
     611  ! Set the neutral nucleation rate to 0.0 if less than 1.0E-7     
     612  IF (jnuc_n.LT.1.E-7) THEN
     613     jnuc_n=0.0
     614  ENDIF
     615 
     616  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     617 
     618  ! Threshold neutral nucleation rate (j > 1/cm3s) parameterization (can be commented out if not needed)
     619  IF (tln .GE. 310.) THEN
     620     rhoatres=EXP(-2.8220714121794250 + 1.1492362322651116E+1*satratln -3.3034839106184218E+3/tln &
     621          & + (-7.1828571490168133E+2*satratln)/tln + 1.4649510835204091E-1*tln                   &
     622          & -3.0442736551916524E-2*satratln*tln -9.3258567137451497E-5*tln**2                     &
     623          & -1.1583992506895649E+1*LOG(satratln) + (1.5184848765906165E+3*LOG(satratln))/tln      &
     624          & + 1.8144983916747057E-2*tln*LOG(satratln)) !1/cm3
     625  ENDIF
     626
     627  IF (tln .GT. 190. .AND. tln .LT. 310.) THEN
     628     rhoatres=EXP(-3.1820396091231999E+2 + 7.2451289153199676*satratln + 2.6729355170089486E+4/tln &
     629          & + (-7.1492506076423069E+2*satratln)/tln + 1.2617291148391978*tln                       &
     630          & - 1.6438112080468487E-2*satratln*tln -1.4185518234553220E-3*tln**2                     &
     631          & -9.2864597847386694*LOG(satratln) + (1.2607421852455602E+3*LOG(satratln))/tln          &
     632          & + 1.3324434472218746E-2*tln*LOG(satratln)) !1/cm3
     633  ENDIF
     634
     635  IF (tln .LT. 185. .AND. tln .GT. 155.) THEN
     636     rhoatres=1.1788859232398459E+5 - 1.0244255702550814E+4*satratln +   &
     637          & 4.6815029684321962E+3*satratln**2 -1.6755952338499657E+2*tln
     638  ENDIF
     639 
     640  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     641 
     642  ! Ion-induced nucleation parameterization
     643 
     644  IF (ipr.GT.0.0) THEN ! if the ion production rate is above zero
     645     
     646     ! Calculate the ion induced nucleation rate wrt. concentration of 1 ion/cm3
     647     
     648     kinrhotresi = 5.3742280876674478E1  - 6.6837931590012266E-3 *LOG(satratli)**(-2)                                     &
     649          & - 1.0142598385422842E-01 * LOG(satratli)**(-1) - 6.4170597272606873E+00 * LOG(satratli)                       &
     650          & - 6.4315798914824518E-01 * LOG(satratli)**2 - 2.4428391714772721E-02 * LOG(satratli)**3                       &
     651          & - 3.5356658734539019E-04 * LOG(satratli)**4 + 2.5400015099140506E-05 * tli * LOG(satratli)**(-2)              &
     652          & - 2.7928900816637790E-04 * tli * LOG(satratli)**(-1) + 4.4108573484923690E-02 * tli * LOG(satratli)           &
     653          & + 6.3943789012475532E-03 * tli * LOG(satratli)**(2) + 2.3164296174966580E-04 * tli * LOG(satratli)**(3)       &
     654          & + 3.0372070669934950E-06 * tli * LOG(satratli)**4 + 3.8255873977423475E-06 * tli**2 * LOG(satratli)**(-1)     &
     655          & - 1.2344793083561629E-04 * tli**2 * LOG(satratli) - 1.7959048869810192E-05 * tli**2 * LOG(satratli)**(2)      &
     656          & - 3.2165622558722767E-07 * tli**2 * LOG(satratli)**3 - 4.7136923780988659E-09 * tli**3 * LOG(satratli)**(-1)  &
     657          & + 1.1873317184482216E-07 * tli**3 * LOG(satratli) + 1.5685860354866621E-08 * tli**3 * LOG(satratli)**2        &
     658          & - 1.4329645891059557E+04 * tli**(-1) + 1.3842599842575321E-01 * tli                                           &
     659          & - 4.1376265912842938E-04 * tli**(2) + 3.9147639775826004E-07 * tli**3
     660     
     661     kinrhotresi=EXP(kinrhotresi) !1/cm3
     662     
     663     IF (kinrhotresi.LT.rhoali) kinetic_i=.true.
     664     
     665     IF (kinetic_i) THEN   
     666!        jnuc_i1=1.0E6*(0.3E-9 + 0.487E-9)**2.*SQRT(8.*3.141593*1.38E-23*(1./(1.661E-27*98.07)+1./(1.661E-27*98.07)))*  &
     667        jnuc_i1=1.0E6*(0.3E-9 + 0.487E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))*  &
     668             &  SQRT(tli)*rhoali !1/cm3s 
     669        ntot_i=1. !set to 1
     670        na_i=1.
     671        x_i=na_i/ntot_i  ! so also set this to 1
     672        rc_i=0.487E-9
     673     ELSE
     674        jnuc_i1 = 3.0108954259038608E+01+tli*6.1176722090512577E+01+(tli**2)*8.7240333618891663E-01+(tli**3)*                 &
     675             & -4.6191788649375719E-03+(tli**(-1))*8.3537059107024481E-01 +                                                   &
     676             & (1.5028549216690628E+01+tli*-1.9310989753720623E-01+(tli**2)*8.0155514634860480E-04+(tli**3)*                  &
     677             & -1.0832730707799128E-06+(tli**(-1))*1.7577660457989019)*(LOG(satratli)**(-2)) +                                &
     678             & (-2.0487870170216488E-01 +  tli * 1.3263949252910405E-03 +  (tli**2) * -8.4195688402450274E-06 +               &
     679             & (tli**3)*1.6154895940993287E-08 + (tli**(-1))*3.8734212545203874E+01) * (LOG(satratli)**(-2)*LOG(rhoali)) +    &
     680             & (1.4955918863858371 +  tli * 9.2290004245522454E+01 +  (tli**2) * -8.9006965195392618E-01 +                    &
     681             & (tli**3) * 2.2319123411013099E-03 + (tli**(-1)) * 4.0180079996840852E-03) *                                    &
     682             & (LOG(satratli)**(-1) * LOG(rhoali)**(-1)) +                                                                    &
     683             & (7.9018031228561085 +  tli * -1.1649433968658949E+01 +  (tli**2) * 1.1400827854910951E-01 +                    &
     684             & (tli**3) * -3.1941526492127755E-04 + (tli**(-1)) * -3.7662115740271446E-01) * (LOG(satratli)**(-1)) +          &
     685             & (1.5725237111225979E+02 +  tli * -1.0051649979836277 +  (tli**2) * 1.1866484014507624E-03 +                    &
     686             & (tli**3) * 7.3557614998540389E-06 + (tli**(-1)) * 2.6270197023115189) * (LOG(satratli)**(-1) * LOG(rhoali)) +  &
     687             & (-1.6973840122470968E+01 +  tli * 1.1258423691432135E-01 +  (tli**2) * -2.9850139351463793E-04 + (tli**3) *    &
     688             & 1.4301286324827064E-07 + (tli**(-1)) * 1.3163389235253725E+01) * (LOG(satratli)**(-1) * LOG(rhoali)**2) +      &
     689             & (-1.0399591631839757 +  tli * 2.7022055588257691E-03 +  (tli**2) * -2.1507467231330936E-06 + (tli**3) *        &
     690             & 3.8059489037584171E-10 + (tli**(-1)) * 1.5000492788553410E+02) * (LOG(satratli)**(-1) * LOG(rhoali)**3) +      &
     691             & (1.2250990965305315 +  tli * 3.0495946490079444E+01 +  (tli**2) * 2.1051563135187106E+01 + (tli**3) *          &
     692             & -8.2200682916580878E-02 + (tli**(-1)) * 2.9965871386685029E-02) * (LOG(rhoali)**(-2)) +                        &
     693             & (4.8281605955680433 +  tli * 1.7346551710836445E+02 +  (tli**2) * -1.0113602140796010E+01 + (tli**3) *         &
     694             & 3.7482518458685089E-02 + (tli**(-1)) * -1.4449998158558205E-01) * (LOG(rhoali)**(-1)) +                        &
     695             & (2.3399230964451237E+02 +  tli * -2.3099267235261948E+01 +  (tli**2) * 8.0122962140916354E-02 +                &
     696             & (tli**3) * 6.1542576994557088E-05 + (tli**(-1)) * 5.3718413254843007) * (LOG(rhoali)) +                        &
     697             & (1.0299715519499360E+02 +  tli * -6.4663357203364136E-02 +  (tli**2) * -2.0487150565050316E-03 +               &
     698             & (tli**3) * 8.7935289055530897E-07 + (tli**(-1)) * 3.6013204601215229E+01) * (LOG(rhoali)**2) +                 &
     699             & (-3.5452115439584042 +  tli * 1.7083445731159330E-02 +  (tli**2) * -1.2552625290862626E-05 + (tli**3) *        &
     700             & 1.2968447449182847E-09 + (tli**(-1)) * 1.5748687512056560E+02) * (LOG(rhoali)**3) +                            &
     701             & (2.2338490119517975 +  tli * 1.0229410216045540E+02 +  (tli**2) * -3.2103611955174052 + (tli**3) *             &
     702             & 1.3397152304977591E-02 + (tli**(-1)) * -2.4155187776460030E-02) * (LOG(satratli)* LOG(rhoali)**(-2)) +         &
     703             & (3.7592282990713963 +  tli * -1.5257988769009816E+02 +  (tli**2) * 2.6113805420558802 + (tli**3) *             &
     704             & -9.0380721653694363E-03 + (tli**(-1)) * -1.3974197138171082E-01) * (LOG(satratli)* LOG(rhoali)**(-1)) +        &
     705             & (1.8293600730573988E+01 +  tli * 1.8344728606002992E+01 +  (tli**2) * -4.0063363221106751E-01 + (tli**3)       &
     706             & * 1.4842749371258522E-03 + (tli**(-1)) * 1.1848846003282287) * (LOG(satratli)) +                               &
     707             & (-1.7634531623032314E+02 +  tli * 4.9011762441271278 +  (tli**2) * -1.3195821562746339E-02 + (tli**3) *        &
     708             & -2.8668619526430859E-05 + (tli**(-1)) * -2.9823396976393551E-01) * (LOG(satratli)* LOG(rhoali)) +              &
     709             & (-3.2944043694275727E+01 +  tli * 1.2517571921051887E-01 +  (tli**2) * 8.3239769771186714E-05 + (tli**3) *     &
     710             & 2.8191859341519507E-07 + (tli**(-1)) * -2.7352880736682319E+01) * (LOG(satratli)* LOG(rhoali)**2) +            &
     711             & (-1.1451811137553243 +  tli * 2.0625997485732494E-03 +  (tli**2) * -3.4225389469233624E-06 + (tli**3) *        &
     712             & 4.4437613496984567E-10 + (tli**(-1)) * 1.8666644332606754E+02) * (LOG(satratli)* LOG(rhoali)**3) +             &
     713             & (3.2270897099493567E+01 +  tli * 7.7898447327513687E-01 +  (tli**2) * -6.5662738484679626E-03 + (tli**3) *     &
     714             & 3.7899330796456790E-06 + (tli**(-1)) * 7.1106427501756542E-01) * (LOG(satratli)**2 * LOG(rhoali)**(-1)) +      &
     715             & (-2.8901906781697811E+01 +  tli * -1.5356398793054860 +  (tli**2) * 1.9267271774384788E-02 + (tli**3) *        &
     716             & -5.3886270475516162E-05 + (tli**(-1)) * 5.0490415975693426E-01) * (LOG(satratli)**2) +                         &
     717             & (3.3365683645733924E+01 +  tli * -3.6114561564894537E-01 +  (tli**2) * 9.2977354471929262E-04 + (tli**3) *     &
     718             & 1.9549769069511355E-07 + (tli**(-1)) * -8.8865930095112855) * (LOG(satratli)**2 * LOG(rhoali)) +               &
     719             & (2.4592563042806375 +  tli * -8.3227071743101084E-03 +  (tli**2) * 8.2563338043447783E-06 + (tli**3) *         &
     720             & -8.4374976698593496E-09 + (tli**(-1)) * -2.0938173949893473E+02) * (LOG(satratli)**2 * LOG(rhoali)**2) +       &
     721             & (4.4099823444352317E+01 +  tli * 2.5915665826835252 +  (tli**2) * -1.6449091819482634E-02 + (tli**3) *         &
     722             & 2.6797249816144721E-05 + (tli**(-1)) * 5.5045672663909995E-01)* satratli
     723        jnuc_i1=EXP(jnuc_i1)
     724       
     725        ntot_i = ABS((-4.8324296064013375E+04 +  tli * 5.0469120697428906E+02 +  (tli**2) * -1.1528940488496042E+00 +         &
     726             & (tli**(-1)) * -8.6892744676239192E+02 + (tli**(3)) * 4.0030302028120469E-04) +                                 &
     727             & (-6.7259105232039847E+03 +  tli * 1.9197488157452008E+02 +  (tli**2) * -1.3602976930126354E+00 +               &
     728             & (tli**(-1)) * -1.1212637938360332E+02 + (tli**(3)) * 2.8515597265933207E-03) *                                 &
     729             & LOG(satratli)**(-2) * LOG(rhoali)**(-2) +                                                                      &
     730             & (2.6216455217763342E+02 +  tli * -2.3687553252750821E+00 +  (tli**2) * 7.4074554767517521E-03 +                &
     731             & (tli**(-1)) * -1.9213956820114927E+03 + (tli**(3)) * -9.3839114856129453E-06) * LOG(satratli)**(-2) +          &
     732             & (3.9652478944137344E+00 +  tli * 1.2469375098256536E-02 +  (tli**2) * -9.9837754694045633E-05 + (tli**(-1)) *  &
     733             & -5.1919499210175138E+02 + (tli**(3)) * 1.6489001324583862E-07) * LOG(satratli)**(-2) * LOG(rhoali) +           &
     734             & (2.4975714429096206E+02 +  tli * 1.7107594562445172E+02 +  (tli**2) * -7.8988711365135289E-01 + (tli**(-1)) *  &
     735             & -2.2243599782483177E+01 + (tli**(3)) * -1.6291523004095427E-04) * LOG(satratli)**(-1) * LOG(rhoali)**(-2) +    &
     736             & (-8.9270715592533611E+02 +  tli * 1.2053538883338946E+02 +  (tli**2) * -1.5490408828541018E+00 + (tli**(-1)) * &
     737             & -1.1243275579419826E+01 + (tli**(3)) * 4.8053105606904655E-03) * LOG(satratli)**(-1) * LOG(rhoali)**(-1) +     &
     738             & (7.6426441642091631E+03 +  tli * -7.1785462414656578E+01 +  (tli**2) * 2.3851864923199523E-01 + (tli**(-1)) *  &
     739             & 8.5591775688708395E+01 + (tli**(3)) * -3.7000473243342858E-04) * LOG(satratli)**(-1) +                         &
     740             & (-5.1516826398607911E+01 +  tli * 9.1385720811460558E-01 +  (tli**2) * -3.5477100262158974E-03 +               &
     741             & (tli**(-1)) * 2.7545544507625586E+03 + (tli**(3)) * 5.4708262093640928E-06) * LOG(satratli)**(-1) * LOG(rhoali) + &
     742             & (-3.0386767129196176E+02 +  tli * -1.1033438883583569E+04 +  (tli**2) * 8.1296859732896067E+01 + (tli**(-1)) * &
     743             & 1.2625883141097162E+01 + (tli**(3)) * -1.2728497822219101E-01) * LOG(rhoali)**(-2) +                           &
     744             & (-3.3763494256461472E+03 +  tli * 3.1916579136391006E+03 +  (tli**2) * -2.7234339474441143E+01 + (tli**(-1)) * &
     745             & -2.1897653262707397E+01 + (tli**(3)) * 5.1788505812259071E-02) * LOG(rhoali)**(-1) +                           &
     746             & (-1.8817843873687068E+03 +  tli * 4.3038072285882070E+00 +  (tli**2) * 6.6244087689671860E-03 + (tli**(-1)) *  &
     747             & -2.7133073605696295E+03 + (tli**(3)) * -1.7951557394285043E-05) * LOG(rhoali) +                                &
     748             & (-1.7668827539244447E+02 +  tli * 4.8160932330629913E-01 +  (tli**2) * -6.3133007671100293E-04 + (tli**(-1)) * &
     749             & 2.5631774669873157E+04 + (tli**(3)) * 4.1534484127873519E-07) * LOG(rhoali)**(2) +                             &
     750             & (-1.6661835889222382E+03 +  tli * 1.3708900504682877E+03 +  (tli**2) * -1.7919060052198969E+01 + (tli**(-1)) * &
     751             & -3.5145029804436405E+01 + (tli**(3)) * 5.1047240947371224E-02) * LOG(satratli)* LOG(rhoali)**(-2) +            &
     752             & (1.0843549363030939E+04 +  tli * -7.3557073636139577E+01 +  (tli**2) * 1.2054625131778862E+00 + (tli**(-1)) *  &
     753             & 1.9358737917864391E+02 + (tli**(3)) * -4.2871620775911338E-03) * LOG(satratli)* LOG(rhoali)**(-1) +            &
     754             & (-2.4269802549752835E+03 +  tli * 1.1348265061941714E+01 +  (tli**2) * -5.0430423939495157E-02 + (tli**(-1)) * &
     755             & 2.3709874548950634E+03 + (tli**(3)) * 1.4091851828620244E-04) * LOG(satratli) +                                &
     756             & (5.2745372575251588E+02 +  tli * -2.6080675912627314E+00 +  (tli**2) * 5.6902218056670145E-03 + (tli**(-1)) *  &
     757             & -3.2149319482897838E+04 + (tli**(3)) * -5.4121996056745853E-06) * LOG(satratli)* LOG(rhoali) +                 &
     758             & (-1.6401959518360403E+01 +  tli * 2.4322962162439640E-01 +  (tli**2) * 1.1744366627725344E-03 + (tli**(-1)) *  &
     759             & -8.2694427518413195E+03 + (tli**(3)) * -5.0028379203873102E-06)* LOG(satratli)**(2) +                          &
     760             & (-2.7556572017167782E+03 +  tli * 4.9293344495058264E+01 +  (tli**2) * -2.6503456520676050E-01 + (tli**(-1)) * &
     761             & 1.2130698030982167E+03 + (tli**(3)) * 4.3530610668042957E-04)* LOG(satratli)**2 * LOG(rhoali)**(-1) +          &
     762             & (-6.3419182228959192E+00 +  tli * 4.0636212834605827E-02 +  (tli**2) * -1.0450112687842742E-04 + (tli**(-1)) * &
     763             & 3.1035882189759656E+02 + (tli**(3)) * 9.4328418657873500E-08)* LOG(satratli)**(-3) +                           &
     764             & (3.0189213304689042E+03 +  tli * -2.3804654203861684E+01 +  (tli**2) * 6.8113013411972942E-02 + (tli**(-1)) *  &
     765             & 6.3112071081188913E+02 + (tli**(3)) * -9.4460854261685723E-05)* (satratli) * LOG(rhoali) +                     &
     766             & (1.1924791930673702E+04 +  tli * -1.1973824959206000E+02 +  (tli**2) * 1.6888713097971020E-01 + (tli**(-1)) *  &
     767             & 1.8735938211539585E+02 + (tli**(3)) * 5.0974564680442852E-04)* (satratli) +                                    &
     768             & (3.6409071302482083E+01 +  tli * 1.7919859306449623E-01 +  (tli**2) * -1.0020116255895206E-03 + (tli**(-1)) *  &
     769             & -8.3521083354432303E+03 + (tli**(3)) * 1.5879900546795635E-06)* satratli * LOG(rhoali)**(2))
     770         
     771        rc_i = (-3.6318550637865524E-08 +  tli * 2.1740704135789128E-09   +  (tli**2) *                          &
     772             & -8.5521429066506161E-12 + (tli**3) * -9.3538647454573390E-15) +                                   &
     773             & (2.1366936839394922E-08 +  tli * -2.4087168827395623E-10 +  (tli**2) * 8.7969869277074319E-13 +   &
     774             & (tli**3) * -1.0294466881303291E-15)* LOG(satratli)**(-2) * LOG(rhoali)**(-1) +                    &
     775             & (-7.7804007761164303E-10 +  tli * 1.0327058173517932E-11 +  (tli**2) * -4.2557697639692428E-14 +  &
     776             & (tli**3) * 5.4082507061618662E-17)* LOG(satratli)**(-2) +                                         &
     777             & (3.2628927397420860E-12 +  tli * -7.6475692919751066E-14 +  (tli**2) * 4.1985816845259788E-16 +   &
     778             & (tli**3) * -6.2281395889592719E-19)* LOG(satratli)**(-2) * LOG(rhoali) +                          &
     779             & (2.0442205540818555E-09 +  tli * 4.0441858911249830E-08 +  (tli**2) * -3.3423487629482825E-10 +   &
     780             & (tli**3) * 6.8000404742985678E-13)* LOG(satratli)**(-1) * LOG(rhoali)**(-2) +                     &
     781             & (1.8381489183824627E-08 +  tli * -8.9853322951518919E-09 +  (tli**2) * 7.5888799566036185E-11 +   &
     782             & (tli**3) * -1.5823457864755549E-13)* LOG(satratli)**(-1) * LOG(rhoali)**(-1) +                    &
     783             & (1.1795760639695057E-07 +  tli * -8.1046722896375875E-10 +  (tli**2) * 9.1868604369041857E-14 +   &
     784             & (tli**3) * 4.7882428237444610E-15)* LOG(satratli)**(-1) +                                         &
     785             & (-4.4028846582545952E-09 +  tli * 4.6541269232626618E-11 +  (tli**2) * -1.1939929984285194E-13 +  &
     786             & (tli**3) * 2.3602037016614437E-17)* LOG(satratli)**(-1) * LOG(rhoali) +                           &
     787             & (2.7885056884209128E-11 +  tli * -4.5167129624119121E-13 +  (tli**2) * 1.6558404997394422E-15 +   &
     788             & (tli**3) * -1.2037336621218054E-18)* LOG(satratli)**(-1) * LOG(rhoali)**2 +                       &
     789             & (-2.3719627171699983E-09 +  tli * -1.5260127909292053E-07 +  (tli**2) * 1.7177017944754134E-09 +  &
     790             & (tli**3) * -4.7031737537526395E-12)* LOG(rhoali)**(-2) +                                          &
     791             & (-5.6946433724699646E-09 +  tli * 8.4629788237081735E-09 +  (tli**2) * -1.7674135187061521E-10 +  &
     792             & (tli**3) * 6.6236547903091862E-13)* LOG(rhoali)**(-1) +                                           &
     793             & (-2.2808617930606012E-08 +  tli * 1.4773376696847775E-10 +  (tli**2) * -1.3076953119957355E-13 +  &
     794             & (tli**3) * 2.3625301497914000E-16)* LOG(rhoali) +                                                 &
     795             & (1.4014269939947841E-10 +  tli * -2.3675117757377632E-12 +  (tli**2) * 5.1514033966707879E-15 +   &
     796             & (tli**3) * -4.8864233454747856E-18)* LOG(rhoali)**2 +                                             &
     797             & (6.5464943868885886E-11 +  tli * 1.6494354816942769E-08 +  (tli**2) * -1.7480097393483653E-10 +   &
     798             & (tli**3) * 4.7460075628523984E-13)* LOG(satratli)* LOG(rhoali)**(-2) +                            &
     799             & (8.4737893183927871E-09 +  tli * -6.0243327445597118E-09 +  (tli**2) * 5.8766070529814883E-11 +   &
     800             & (tli**3) * -1.4926748560042018E-13)* LOG(satratli)* LOG(rhoali)**(-1) +                           &
     801             & (1.0761964135701397E-07 +  tli * -1.0142496009071148E-09 +  (tli**2) * 2.1337312466519190E-12 +   &
     802             & (tli**3) * 1.6376014957685404E-15)* LOG(satratli) +                                               &
     803             & (-3.5621571395968670E-09 +  tli * 4.1175339587760905E-11 +  (tli**2) * -1.3535372357998504E-13 +  &
     804             & (tli**3) * 8.9334219536920720E-17)* LOG(satratli)* LOG(rhoali) +                                  &
     805             & (2.0700482083136289E-11 +  tli * -3.9238944562717421E-13 +  (tli**2) * 1.5850961422040196E-15 +   &
     806             & (tli**3) * -1.5336775610911665E-18)* LOG(satratli)* LOG(rhoali)**2 +                              &
     807             & (1.8524255464416206E-09 +  tli * -2.1959816152743264E-11 +  (tli**2) * -6.4478119501677012E-14 +  &
     808             & (tli**3) * 5.5135243833766056E-16)* LOG(satratli)**2 * LOG(rhoali)**(-1) +                        &
     809             & (1.9349488650922679E-09 +  tli * -2.2647295919976428E-11 +  (tli**2) * 9.2917479748268751E-14 +   &
     810             & (tli**3) * -1.2741959892173170E-16)* LOG(satratli)**2 +                                           &
     811             & (2.1484978031650972E-11 +  tli * -9.3976642475838013E-14 +  (tli**2) * -4.8892738002751923E-16 +  &
     812             & (tli**3) * 1.4676120441783832E-18)* LOG(satratli)**2 * LOG(rhoali) +                              &
     813             & (6.7565715216420310E-13 +  tli * -3.5421162549480807E-15 +  (tli**2) * -3.4201196868693569E-18 +  &
     814             & (tli**3) * 2.2260187650412392E-20)* LOG(satratli)**3 * LOG(rhoali)
     815                   
     816        na_i=x_i*ntot_i
     817        IF (na_i .LT. 1.) THEN
     818!           print *, 'Warning: number of acid molecules < 1 in nucleation regime, setting na_n=1'
     819           na_n=1.0
     820        ENDIF
     821     ENDIF
     822   
     823     jnuc_i=jnuc_i1
     824     ! Ion loss rate (1/s)
     825     xloss=csi+jnuc_i
     826     
     827     ! Recombination (here following Brasseur and Chatel, 1983)   
     828     recomb=6.0E-8*SQRT(300./tli)+6.0E-26*airn*(300./tli)**4
     829     
     830     ! Small ion concentration in air (1/cm3) (following Dunne et al., 2016)
     831     ! max function is to avoid n_i to go practically zero at very high J_ion
     832     n_i=MAX(0.01,(SQRT(xloss**2.0+4.0*recomb*ipr)-xloss)/(2.0*recomb))
     833     
     834     ! Ion-induced nucleation rate
     835     ! Min function is to ensure that max function above does not cause J_ion to overshoot
     836     jnuc_i=MIN(ipr,n_i*jnuc_i1)
     837     ! Set the ion-induced nucleation rate to 0.0 if less than 1.0E-7     
     838     IF (jnuc_i.LT.1.E-7) THEN
     839        jnuc_i=0.0
     840     ENDIF
     841
     842  ENDIF
     843
     844!--conversion from double precision to float in case the model is run in single precision
     845  jnuc_n_real   = jnuc_n
     846  ntot_n_real   = ntot_n
     847  jnuc_i_real   = jnuc_i
     848  ntot_i_real   = ntot_i
     849  x_n_real      = x_n
     850  x_i_real      = x_i
     851  na_n_real     = na_n
     852  na_i_real     = na_i
     853  rc_n_real     = rc_n
     854  rc_i_real     = rc_i
     855  n_i_real      = n_i
     856  rhoatres_real = rhoatres
     857 
     858END SUBROUTINE newbinapara
     859
    281860END MODULE nucleation_tstep_mod

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/ocs_to_so2.F90

    • Property svn:keywords set to Id
    r2752 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE ocs_to_so2(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/so2_to_h2so4.F90

    • Property svn:keywords set to Id
    r2752 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE SO2_TO_H2SO4(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/sulfate_aer_mod.F90

    • Property svn:keywords set to Id
    r2690 r3605  
     1!
     2! $Id$
     3!
    14MODULE sulfate_aer_mod
    25

  • LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/traccoag_mod.F90

    • Property svn:keywords set to Id
    r3114 r3605  
     1!
     2! $Id$
     3!
    14MODULE traccoag_mod
    25!
    … …  
    1619    USE infotrac
    1720    USE aerophys
    18     USE geometry_mod, ONLY : cell_area
     21    USE geometry_mod, ONLY : cell_area, boundslat
    1922    USE mod_grid_phy_lmdz
    2023    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
    … …  
    2427    USE phys_local_var_mod, ONLY: stratomask
    2528    USE YOMCST
     29    USE print_control_mod, ONLY: lunout
     30    USE strataer_mod
     31    USE phys_cal_mod, ONLY : year_len
    2632
    2733    IMPLICIT NONE
    … …  
    5258! Local variables
    5359!----------------
    54 ! flag for sulfur emission scenario: (0) background aerosol ; (1) volcanic eruption ; (2) stratospheric aerosol injections (SAI)
    55     INTEGER,PARAMETER  :: flag_sulf_emit=2
    56 !
    57 !--flag_sulf_emit=1 --example Pinatubo
    58     INTEGER,PARAMETER :: year_emit_vol=1991          ! year of emission date
    59     INTEGER,PARAMETER :: mth_emit_vol=6              ! month of emission date
    60     INTEGER,PARAMETER :: day_emit_vol=15             ! day of emission date
    61     REAL,PARAMETER    :: m_aer_emiss_vol=7.e9   ! emitted sulfur mass in kgS, e.g. 7Tg(S)=14Tg(SO2)
    62     REAL,PARAMETER    :: altemiss_vol=17.e3     ! emission altitude in m
    63     REAL,PARAMETER    :: sigma_alt_vol=1.e3     ! standard deviation of emission altitude in m
    64     REAL,PARAMETER    :: xlat_vol=15.14         ! latitude of volcano in degree
    65     REAL,PARAMETER    :: xlon_vol=120.35        ! longitude of volcano in degree
    66 
    67 !--flag_sulf_emit=2 --SAI
    68     REAL,PARAMETER    :: m_aer_emiss_sai=1.e10  ! emitted sulfur mass in kgS, eg 1e9=1TgS, 1e10=10TgS
    69     REAL,PARAMETER    :: altemiss_sai=17.e3     ! emission altitude in m
    70     REAL,PARAMETER    :: sigma_alt_sai=1.e3     ! standard deviation of emission altitude in m
    71     REAL,PARAMETER    :: xlat_sai=0.01          ! latitude of SAI in degree
    72     REAL,PARAMETER    :: xlon_sai=120.35        ! longitude of SAI in degree
    73 
    74 !--other local variables
    75     INTEGER                                :: it, k, i, ilon, ilev, itime, i_int
     60    REAL                                   :: m_aer_emiss_vol_daily ! daily injection mass emission
     61    INTEGER                                :: it, k, i, ilon, ilev, itime, i_int, ieru
    7662    LOGICAL,DIMENSION(klon,klev)           :: is_strato           ! true = above tropopause, false = below
    7763    REAL,DIMENSION(klon,klev)              :: m_air_gridbox       ! mass of air in every grid box [kg]
    … …  
    9076    REAL,DIMENSION(klev)                   :: zdm                 ! mass of atm. model layer in kg
    9177    REAL,DIMENSION(klon,klev)              :: dens_aer            ! density of aerosol particles [kg/m3 aerosol] with default H2SO4 mass fraction
    92     REAL                                   :: dlat, dlon          ! d latitude and d longitude of grid in degree
    9378    REAL                                   :: emission            ! emission
     79    REAL                                   :: theta_min, theta_max ! for SAI computation between two latitudes
     80    REAL                                   :: dlat_loc
    9481
    9582    IF (is_mpi_root) THEN
    96       PRINT *,'in traccoag: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour
     83       WRITE(lunout,*) 'in traccoag: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour
     84       WRITE(lunout,*) 'IN traccoag flag_sulf_emit: ',flag_sulf_emit
    9785    ENDIF
    98 
    99     dlat=180./2./FLOAT(nbp_lat)   ! d latitude in degree
    100     dlon=360./2./FLOAT(nbp_lon)   ! d longitude in degree
    101 
     86   
    10287    DO it=1, nbtr_bin
    10388      r_bin(it)=mdw(it)/2.
    … …  
    120105    IF (debutphy .and. is_mpi_root) THEN
    121106      DO it=1, nbtr_bin
    122         PRINT *,'radius bin', it, ':', r_bin(it), '(from',  r_lower(it), 'to', r_upper(it), ')'
     107        WRITE(lunout,*) 'radius bin', it, ':', r_bin(it), '(from',  r_lower(it), 'to', r_upper(it), ')'
    123108      ENDDO
    124109    ENDIF
    … …  
    170155      !--only emit on day of eruption
    171156      ! stretch emission over one day of Pinatubo eruption
    172       IF (year_cur==year_emit_vol.AND.mth_cur==mth_emit_vol.AND.day_cur==day_emit_vol) THEN
    173 !
    174         DO i=1,klon
    175           !Pinatubo eruption at 15.14N, 120.35E
    176           IF  ( xlat(i).GE.xlat_vol-dlat .AND. xlat(i).LT.xlat_vol+dlat .AND. &
    177                 xlon(i).GE.xlon_vol-dlon .AND. xlon(i).LT.xlon_vol+dlon ) THEN
    178 !
    179           PRINT *,'coordinates of volcanic injection point=',xlat(i), xlon(i), day_cur, mth_cur, year_cur
    180 !         compute altLMDz
    181             altLMDz(:)=0.0
    182             DO k=1, klev
    183               zrho=pplay(i,k)/t_seri(i,k)/RD       !air density in kg/m3
    184               zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG  !mass of layer in kg
    185               zdz=zdm(k)/zrho                      !thickness of layer in m
    186               altLMDz(k+1)=altLMDz(k)+zdz          !altitude of interface
    187             ENDDO
    188             !compute distribution of emission to vertical model layers (based on Gaussian peak in altitude)
    189             f_lay_sum=0.0
    190             DO k=1, klev
    191               f_lay_emiss(k)=0.0
    192               DO i_int=1, n_int_alt
    193                 alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
    194                 f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_vol)* &
    195                 &              exp(-0.5*((alt-altemiss_vol)/sigma_alt_vol)**2.)*   &
    196                 &              (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
    197               ENDDO
    198               f_lay_sum=f_lay_sum+f_lay_emiss(k)
    199             ENDDO
    200             !correct for step integration error
    201             f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum
    202             !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
    203             !vertically distributed emission
    204             DO k=1, klev
    205               ! stretch emission over one day (minus one timestep) of Pinatubo eruption
    206               emission=m_aer_emiss_vol*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/1./(86400.-pdtphys)
    207               tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys
    208               budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol
    209             ENDDO
    210           ENDIF ! emission grid cell
    211         ENDDO ! klon loop
    212       ENDIF ! emission period
    213 
     157       DO ieru=1, nErupt
     158          IF (year_cur==year_emit_vol(ieru).AND.mth_cur==mth_emit_vol(ieru).AND.&
     159               day_cur>=day_emit_vol(ieru).AND.day_cur<(day_emit_vol(ieru)+injdur)) THEN
     160             !
     161             ! daily injection mass emission - NL
     162             m_aer_emiss_vol_daily = m_aer_emiss_vol(ieru)/(REAL(injdur)*REAL(ponde_lonlat_vol(ieru)))
     163             WRITE(lunout,*) 'IN traccoag DD m_aer_emiss_vol(ieru)=',m_aer_emiss_vol(ieru), &
     164                  'ponde_lonlat_vol(ieru)=',ponde_lonlat_vol(ieru),'(injdur*ponde_lonlat_vol(ieru))', &
     165                  (injdur*ponde_lonlat_vol(ieru)),'m_aer_emiss_vol_daily=',m_aer_emiss_vol_daily,'ieru=',ieru
     166             WRITE(lunout,*) 'IN traccoag, dlon=',dlon
     167             DO i=1,klon
     168                !Pinatubo eruption at 15.14N, 120.35E
     169                dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3)) ! dlat = half difference of boundary latitudes
     170                WRITE(lunout,*) 'IN traccoag, dlat=',dlat_loc
     171                IF ( xlat(i).GE.xlat_min_vol(ieru)-dlat_loc .AND. xlat(i).LT.xlat_max_vol(ieru)+dlat_loc .AND. &
     172                     xlon(i).GE.xlon_min_vol(ieru)-dlon .AND. xlon(i).LT.xlon_max_vol(ieru)+dlon ) THEN
     173                   !
     174                   WRITE(lunout,*) 'coordinates of volcanic injection point=',xlat(i),xlon(i),day_cur,mth_cur,year_cur
     175                   WRITE(lunout,*) 'DD m_aer_emiss_vol_daily=',m_aer_emiss_vol_daily
     176                   !         compute altLMDz
     177                   altLMDz(:)=0.0
     178                   DO k=1, klev
     179                      zrho=pplay(i,k)/t_seri(i,k)/RD       !air density in kg/m3
     180                      zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG  !mass of layer in kg
     181                      zdz=zdm(k)/zrho                      !thickness of layer in m
     182                      altLMDz(k+1)=altLMDz(k)+zdz          !altitude of interface
     183                   ENDDO
     184
     185                   SELECT CASE(flag_sulf_emit_distrib)
     186                   
     187                   CASE(0) ! Gaussian distribution
     188                   !compute distribution of emission to vertical model layers (based on Gaussian peak in altitude)
     189                   f_lay_sum=0.0
     190                   DO k=1, klev
     191                      f_lay_emiss(k)=0.0
     192                      DO i_int=1, n_int_alt
     193                         alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
     194                         f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_vol(ieru))* &
     195                              &              exp(-0.5*((alt-altemiss_vol(ieru))/sigma_alt_vol(ieru))**2.)*   &
     196                              &              (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
     197                      ENDDO
     198                      f_lay_sum=f_lay_sum+f_lay_emiss(k)
     199                   ENDDO
     200                   
     201                   CASE(1) ! Uniform distribution
     202                   ! In this case, parameter sigma_alt_vol(ieru) is considered to be half the
     203                   ! height of the injection, centered around altemiss_vol(ieru)
     204                   DO k=1, klev
     205                      f_lay_emiss(k)=max(min(altemiss_vol(ieru)+sigma_alt_vol(ieru),altLMDz(k+1))- &
     206                      & max(altemiss_vol(ieru)-sigma_alt_vol(ieru),altLMDz(k)),0.)/(2.*sigma_alt_vol(ieru))
     207                      f_lay_sum=f_lay_sum+f_lay_emiss(k)
     208                   ENDDO
     209
     210                   END SELECT        ! End CASE over flag_sulf_emit_distrib)
     211
     212                   WRITE(lunout,*) "IN traccoag m_aer_emiss_vol=",m_aer_emiss_vol(ieru)
     213                   WRITE(lunout,*) "IN traccoag f_lay_emiss=",f_lay_emiss
     214                   !correct for step integration error
     215                   f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum
     216                   !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
     217                   !vertically distributed emission
     218                   DO k=1, klev
     219                      ! stretch emission over one day of Pinatubo eruption
     220                      emission=m_aer_emiss_vol_daily*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/1./(86400.-pdtphys)
     221                      tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys
     222                      budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol
     223                   ENDDO
     224                ENDIF ! emission grid cell
     225             ENDDO ! klon loop
     226             WRITE(lunout,*) "IN traccoag (ieru=",ieru,") m_aer_emiss_vol_daily=",m_aer_emiss_vol_daily
     227          ENDIF ! emission period
     228       ENDDO ! eruption number
     229       
    214230    CASE(2) ! stratospheric aerosol injections (SAI)
    215231!
    … …  
    217233!       SAI standard scenario with continuous emission from 1 grid point at the equator
    218234!       SAI emission on single month
    219 !       IF  ((mth_cur==4 .AND. &
    220235!       SAI continuous emission o
    221         IF  ( xlat(i).GE.xlat_sai-dlat .AND. xlat(i).LT.xlat_sai+dlat .AND. &
     236        dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3)) ! dlat = half difference of boundary latitudes
     237        IF  ( xlat(i).GE.xlat_sai-dlat_loc .AND. xlat(i).LT.xlat_sai+dlat_loc .AND. &
    222238          &   xlon(i).GE.xlon_sai-dlon .AND. xlon(i).LT.xlon_sai+dlon ) THEN
    223239!
    224           PRINT *,'coordinates of SAI point=',xlat(i), xlon(i), day_cur, mth_cur, year_cur
    225240!         compute altLMDz
    226241          altLMDz(:)=0.0
    … …  
    231246            altLMDz(k+1)=altLMDz(k)+zdz          !altitude of interface
    232247          ENDDO
     248
     249          SELECT CASE(flag_sulf_emit_distrib)
     250
     251          CASE(0) ! Gaussian distribution
    233252          !compute distribution of emission to vertical model layers (based on Gaussian peak in altitude)
    234253          f_lay_sum=0.0
    235           DO k=1, klev
    236             f_lay_emiss(k)=0.0
    237             DO i_int=1, n_int_alt
    238               alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
    239               f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_sai)* &
    240               &              exp(-0.5*((alt-altemiss_sai)/sigma_alt_sai)**2.)*   &
    241               &              (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
    242             ENDDO
    243             f_lay_sum=f_lay_sum+f_lay_emiss(k)
    244           ENDDO
     254               DO k=1, klev
     255                     f_lay_emiss(k)=0.0
     256                     DO i_int=1, n_int_alt
     257                         alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
     258                         f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_sai)* &
     259                         &              exp(-0.5*((alt-altemiss_sai)/sigma_alt_sai)**2.)*   &
     260                         &              (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
     261                     ENDDO
     262                     f_lay_sum=f_lay_sum+f_lay_emiss(k)
     263               ENDDO
     264
     265          CASE(1) ! Uniform distribution
     266          f_lay_sum=0.0
     267          ! In this case, parameter sigma_alt_vol(ieru) is considered to be half
     268          ! the height of the injection, centered around altemiss_sai
     269               DO k=1, klev
     270                    f_lay_emiss(k)=max(min(altemiss_sai+sigma_alt_sai,altLMDz(k+1))- &
     271                    & max(altemiss_sai-sigma_alt_sai,altLMDz(k)),0.)/(2.*sigma_alt_sai)
     272                    f_lay_sum=f_lay_sum+f_lay_emiss(k)
     273               ENDDO
     274
     275          END SELECT ! Gaussian or uniform distribution
     276
    245277          !correct for step integration error
    246278          f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum
    … …  
    249281          DO k=1, klev
    250282            ! stretch emission over whole year (360d)
    251             emission=m_aer_emiss_sai*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/360./86400. 
     283            emission=m_aer_emiss_sai*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/FLOAT(year_len)/86400. 
    252284            tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys
    253285            budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol
    254286          ENDDO
     287
    255288!          !emission as monodisperse particles with 0.1um dry radius (BIN21)
    256289!          !vertically distributed emission
    257290!          DO k=1, klev
    258291!            ! stretch emission over whole year (360d)
    259 !            emission=m_aer_emiss*(mH2SO4mol/mSatom)/m_part_dry(21)/m_air_gridbox(i,k)*f_lay_emiss(k)/360./86400
     292!            emission=m_aer_emiss*(mH2SO4mol/mSatom)/m_part_dry(21)/m_air_gridbox(i,k)*f_lay_emiss(k)/FLOAT(year_len)/86400.
     293!            tr_seri(i,k,id_BIN01_strat+20)=tr_seri(i,k,id_BIN01_strat+20)+emission*pdtphys
     294!            budg_emi_part(i)=budg_emi_part(i)+emission*zdm(k)*mSatom/mH2SO4mol
     295!          ENDDO
     296        ENDIF ! emission grid cell
     297      ENDDO ! klon loop
     298
     299    CASE(3) ! --- SAI injection over a single band of longitude and between
     300            !     lat_min and lat_max
     301
     302    DO i=1,klon
     303!       SAI scenario with continuous emission
     304        dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3)) ! dlat = half difference of boundary latitudes
     305        theta_min = max(xlat(i)-dlat_loc,xlat_min_sai)
     306        theta_max = min(xlat(i)+dlat_loc,xlat_max_sai)
     307        IF  ( xlat(i).GE.xlat_min_sai-dlat_loc .AND. xlat(i).LT.xlat_max_sai+dlat_loc .AND. &
     308          &   xlon(i).GE.xlon_sai-dlon .AND. xlon(i).LT.xlon_sai+dlon ) THEN
     309!
     310!         compute altLMDz
     311          altLMDz(:)=0.0
     312          DO k=1, klev
     313            zrho=pplay(i,k)/t_seri(i,k)/RD       !air density in kg/m3
     314            zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG  !mass of layer in kg
     315            zdz=zdm(k)/zrho                      !thickness of layer in m
     316            altLMDz(k+1)=altLMDz(k)+zdz          !altitude of interface
     317          ENDDO
     318
     319          SELECT CASE(flag_sulf_emit_distrib)
     320
     321          CASE(0) ! Gaussian distribution
     322          !compute distribution of emission to vertical model layers (based on
     323          !Gaussian peak in altitude)
     324          f_lay_sum=0.0
     325               DO k=1, klev
     326                     f_lay_emiss(k)=0.0
     327                     DO i_int=1, n_int_alt
     328                         alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
     329                         f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_sai)* &
     330                         & exp(-0.5*((alt-altemiss_sai)/sigma_alt_sai)**2.)*   &
     331                         & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
     332                     ENDDO
     333                     f_lay_sum=f_lay_sum+f_lay_emiss(k)
     334               ENDDO
     335
     336          CASE(1) ! Uniform distribution
     337          f_lay_sum=0.0
     338          ! In this case, parameter sigma_alt_vol(ieru) is considered to be half
     339          ! the height of the injection, centered around altemiss_sai
     340               DO k=1, klev
     341                    f_lay_emiss(k)=max(min(altemiss_sai+sigma_alt_sai,altLMDz(k+1))- &
     342                    & max(altemiss_sai-sigma_alt_sai,altLMDz(k)),0.)/(2.*sigma_alt_sai)
     343                    f_lay_sum=f_lay_sum+f_lay_emiss(k)
     344               ENDDO
     345
     346          END SELECT ! Gaussian or uniform distribution
     347
     348          !correct for step integration error
     349          f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum
     350          !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
     351          !vertically distributed emission
     352          DO k=1, klev
     353            ! stretch emission over whole year (360d)
     354            emission=m_aer_emiss_sai*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/ &
     355                      & FLOAT(year_len)/86400.*(sin(theta_max/180.*RPI)-sin(theta_min/180.*RPI))/ &
     356                      & (sin(xlat_max_sai/180.*RPI)-sin(xlat_min_sai/180.*RPI))
     357            tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys
     358            budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol
     359          ENDDO
     360
     361!          !emission as monodisperse particles with 0.1um dry radius (BIN21)
     362!          !vertically distributed emission
     363!          DO k=1, klev
     364!            ! stretch emission over whole year (360d)
     365!            emission=m_aer_emiss*(mH2SO4mol/mSatom)/m_part_dry(21)/m_air_gridbox(i,k)*f_lay_emiss(k)/year_len/86400
    260366!            tr_seri(i,k,id_BIN01_strat+20)=tr_seri(i,k,id_BIN01_strat+20)+emission*pdtphys
    261367!            budg_emi_part(i)=budg_emi_part(i)+emission*zdm(k)*mSatom/mH2SO4mol
    … …  
    291397        IF (mdw(it) .LT. 2.5e-6) THEN
    292398          !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) &
    293           !assume that particles consist of ammonium sulfate at the surface (132g/mol) and are dry at T = 20 deg. C and 50 perc. humidity
     399          !assume that particles consist of ammonium sulfate at the surface (132g/mol)
     400          !and are dry at T = 20 deg. C and 50 perc. humidity
    294401          surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas) &
    295402                           & *132./98.*dens_aer_dry*4./3.*RPI*(mdw(it)/2.)**3 &

  • LMDZ6/branches/Ocean_skin/libf/phylmd/YOMCST.h

    r3429 r3605  
    2020      REAL RSIGMA
    2121! A1.4 Thermodynamic gas phase
    22       REAL R,RMD,RMO3,RMCO2,RMC,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
     22      REAL RMO3,RMCO2,RMC,RMCH4,RMN2O,RMCFC11,RMCFC12
     23      REAL R,RMD,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
    2324      REAL RKAPPA,RETV, eps_w
    2425! A1.5,6 Thermodynamic liquid,solid phases
    … …  
    3536     &      ,RA    ,RG    ,R1SA                                         &
    3637     &      ,RSIGMA                                                     &
    37      &      ,R     ,RMD   ,RMO3  ,RMCO2, RMC, RMV   ,RD    ,RV    ,RCPD &
     38     &      ,R     ,RMD   ,RMV   ,RD    ,RV    ,RCPD                    &
     39     &      ,RMO3  ,RMCO2 ,RMC   ,RMCH4 ,RMN2O ,RMCFC11 ,RMCFC12        &
    3840     &      ,RCPV  ,RCVD  ,RCVV  ,RKAPPA,RETV, eps_w                    &
    3941     &      ,RCW   ,RCS                                                 &

  • LMDZ6/branches/Ocean_skin/libf/phylmd/acama_gwd_rando_m.F90

    • Property svn:keywords set to Id
    r3198 r3605  
     1!
     2! $Id$
     3!
    14module ACAMA_GWD_rando_m
    25
    … …  
    120123  !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp)
    121124
    122     CHARACTER (LEN=20) :: modname='flott_gwd_rando'
     125    CHARACTER (LEN=20) :: modname='acama_gwd_rando_m'
    123126    CHARACTER (LEN=80) :: abort_message
    124127
    … …  
    208211
    209212    IF(DELTAT < DTIME)THEN
    210        PRINT *, 'flott_gwd_rando: deltat < dtime!'
    211        STOP 1
     213!       PRINT *, 'flott_gwd_rando: deltat < dtime!'
     214!       STOP 1
     215       abort_message=' deltat < dtime! '
     216       CALL abort_physic(modname,abort_message,1)
    212217    ENDIF
    213218
    214219    IF (KLEV < NW) THEN
    215        PRINT *, 'flott_gwd_rando: you will have problem with random numbers'
    216        STOP 1
     220!       PRINT *, 'flott_gwd_rando: you will have problem with random numbers'
     221!       STOP 1
     222       abort_message=' you will have problem with random numbers'
     223       CALL abort_physic(modname,abort_message,1)
    217224    ENDIF
    218225

  • LMDZ6/branches/Ocean_skin/libf/phylmd/add_phys_tend_mod.F90

    r2848 r3605  
     1!
     2! $Id$
     3!
    14!
    25MODULE add_phys_tend_mod
    … …  
    98101
    99102USE dimphy, ONLY: klon, klev
    100 USE phys_state_var_mod, ONLY : dtime
     103USE phys_state_var_mod, ONLY : phys_tstep
    101104USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, t_seri
    102105USE phys_state_var_mod, ONLY: ftsol
    … …  
    451454    ! ------------------------------------------------
    452455
    453     d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/dtime
    454     d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/dtime
    455     d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/dtime
     456    d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep
     457    d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep
     458    d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep
    456459    d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:)
    457460
    458     d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/dtime
    459 
    460     d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/dtime
    461     d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/dtime
    462     d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/dtime
    463     d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/dtime
    464 
    465     d_h_col = (zh_col(:,2)-zh_col(:,1))/dtime
     461    d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep
     462
     463    d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep
     464    d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep
     465    d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep
     466    d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep
     467
     468    d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep
    466469
    467470  end if ! end if (fl_ebil .GT. 0)
    … …  
    494497!======================================================================
    495498
    496 USE phys_state_var_mod, ONLY : dtime, ftsol
     499USE phys_state_var_mod, ONLY : phys_tstep, ftsol
    497500USE geometry_mod, ONLY: longitude_deg, latitude_deg
    498501USE print_control_mod, ONLY: prt_level
    … …  
    621624    ! ------------------------------------------------
    622625
    623     d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/dtime
    624     d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/dtime
    625     d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/dtime
     626    d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep
     627    d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep
     628    d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep
    626629    d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:)
    627630
    628     d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/dtime
     631    d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep
    629632
    630633   print *,'zdu ', zdu
    … …  
    632635   print *,'d_ek_col, zek_col(2), zek_col(1) ',d_ek_col(1), zek_col(1,2), zek_col(1,1)
    633636
    634     d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/dtime
    635     d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/dtime
    636     d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/dtime
    637     d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/dtime
    638 
    639     d_h_col = (zh_col(:,2)-zh_col(:,1))/dtime
     637    d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep
     638    d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep
     639    d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep
     640    d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep
     641
     642    d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep
    640643
    641644  end if ! end if (fl_ebil .GT. 0)
    … …  
    716719
    717720USE dimphy, ONLY: klon, klev
    718 USE phys_state_var_mod, ONLY : dtime
     721USE phys_state_var_mod, ONLY : phys_tstep
    719722USE phys_state_var_mod, ONLY : topsw, toplw, solsw, sollw, rain_con, snow_con
    720723USE geometry_mod, ONLY: longitude_deg, latitude_deg

  • LMDZ6/branches/Ocean_skin/libf/phylmd/alpale_th.F90

    • Property svn:keywords set to Id
    r3209 r3605  
     1!
     2! $Id$
     3!
    14SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area,  &
    25                       cin, s2, n2,  &
    … …  
    6265 REAL umexp  ! expression of (1.-exp(-x))/x valid for all x, especially when x->0
    6366 REAL x
     67     CHARACTER (LEN=20) :: modname='alpale_th'
     68     CHARACTER (LEN=80) :: abort_message
     69     
    6470 umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + &
    6571            (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x)))  !!! correct formula            (jyg)
    … …  
    104110             !
    105111             IF (prt_level .GE. 10) THEN
    106                 print *,'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &
     112                WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &
    107113                     cin, ale_bl_stat, alp_bl, alp_bl_stat
    108114             ENDIF
    … …  
    122128             !
    123129             IF (prt_level .GE. 10) THEN
    124                 print *,'random_notrig, tau_trig ', &
     130                WRITE(lunout,*)'random_notrig, tau_trig ', &
    125131                     random_notrig, tau_trig
    126                 print *,'s_trig,s2,n2 ', &
     132                WRITE(lunout,*)'s_trig,s2,n2 ', &
    127133                     s_trig,s2,n2
    128134             ENDIF
    … …  
    178184             !
    179185             IF (prt_level .GE. 10) THEN
    180                 print *,'proba_notrig, ale_bl_trig ', &
     186                WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
    181187                     proba_notrig, ale_bl_trig
    182188             ENDIF
    … …  
    224230        !
    225231        IF (prt_level .GE. 10) THEN
    226            print *,'cin, ale_bl_stat, alp_bl_stat ', &
     232           WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', &
    227233                cin, ale_bl_stat, alp_bl_stat
    228234        ENDIF
    … …  
    253259        !
    254260        IF (prt_level .GE. 10) THEN
    255            print *,'random_notrig, tau_trig ', &
     261           WRITE(lunout,*)'random_notrig, tau_trig ', &
    256262                random_notrig, tau_trig
    257            print *,'s_trig,s2,n2 ', &
     263           WRITE(lunout,*)'s_trig,s2,n2 ', &
    258264                s_trig,s2,n2
    259265        ENDIF
    … …  
    289295        !
    290296        IF (prt_level .GE. 10) THEN
    291            print *,'proba_notrig, ale_bl_trig ', &
     297           WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
    292298                proba_notrig, ale_bl_trig
    293299        ENDIF
    … …  
    300306
    301307          IF (prt_level .GE. 10) THEN
    302              print *,'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &
     308             WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &
    303309                      ale_bl_trig(1), alp_bl_stat(1), birth_rate(1)
    304310          ENDIF
    … …  
    310316          if (iflag_coupl==2) then
    311317             IF (prt_level .GE. 10) THEN
    312                 print*,'Couplage Thermiques/Emanuel seulement si T<0'
     318                WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0'
    313319             ENDIF
    314320             do i=1,klon
    … …  
    317323                endif
    318324             enddo
    319     print *,'In order to run with iflag_coupl=2, you have to comment out the following stop'
    320              STOP
     325!    print *,'In order to run with iflag_coupl=2, you have to comment out the following stop'
     326!             STOP
     327             abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort'
     328             CALL abort_physic(modname,abort_message,1)
    321329          endif
    322330   RETURN

  • LMDZ6/branches/Ocean_skin/libf/phylmd/atm2geo.F90

    r2429 r3605  
    55  USE dimphy
    66  USE mod_phys_lmdz_para
     7  USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat
    78  IMPLICIT NONE
    89  INCLUDE 'YOMCST.h'
     10
     11  CHARACTER (len = 6)                :: clmodnam
     12  CHARACTER (len = 20)               :: modname = 'atm2geo'
     13  CHARACTER (len = 80)               :: abort_message
     14
    915!
    1016! Change wind local atmospheric coordinates to geocentric
    1117!
     18! Geocentric :
     19! axe x is eastward : crosses (0 N, 0 E) point.
     20! axe y crosses (0 N, 90 E) point.
     21! axe z is 'up' : crosses north pole
    1222  INTEGER, INTENT (in)                 :: im, jm
    13   REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn
     23  REAL, DIMENSION (im,jm), INTENT (in) :: pte  ! Eastward vector component
     24  REAL, DIMENSION (im,jm), INTENT (in) :: ptn  ! Northward vector component
    1425  REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
    15   REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz
    16  
    17   REAL :: rad
    18 
     26  REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz  ! Component in the geocentric referential
     27  REAL :: rad, reps
    1928
    2029  rad = rpi / 180.0E0
     30  reps = 1.0e-5
    2131 
    2232  pxx(:,:) = &
    … …  
    3141       + ptn(:,:) * COS(rad * plat (:,:))
    3242 
    33 ! Value at North Pole 
    34   IF (is_north_pole_dyn) THEN
    35      pxx(:, 1) = - pte (1, 1)
    36      pyy(:, 1) = - ptn (1, 1)
    37      pzz(:, 1) = pzz(1,1)
    38   ENDIF
     43  IF (grid_type==regular_lonlat) THEN
     44  ! Value at North Pole 
     45    IF (is_north_pole_dyn) THEN
     46       pxx(:, 1) = - pte (1, 1)
     47       pyy(:, 1) = - ptn (1, 1)
     48       pzz(:, 1) = pzz(1,1) ! => 0
     49    ENDIF
    3950
    40 ! Value at South Pole
    41   IF (is_south_pole_dyn) THEN
    42      pxx(:,jm) = pxx(1,jm)
    43      pyy(:,jm) = pyy(1,jm)
    44      pzz(:,jm) = pzz(1,jm)
    45   ENDIF
     51  ! Value at South Pole
     52    IF (is_south_pole_dyn) THEN
     53      pxx(:,jm) = pxx(1,jm)
     54       pyy(:,jm) = pyy(1,jm)
     55       pzz(:,jm) = pzz(1,jm) ! => 0
     56    ENDIF
     57 
     58  ELSE IF (grid_type==unstructured) THEN
     59     ! Pole nord pour Dynamico
     60     WHERE ( plat(:,:) >= 90.0d+0-reps )
     61        pxx (:,:) = -ptn (:,:)
     62        pyy (:,:) =  pte (:,:)
     63        pzz (:,:) =  0.0e0
     64     END WHERE
     65
     66  ELSE
     67     abort_message='Problem: unknown grid type'
     68     CALL abort_physic(modname,abort_message,1)
     69  END IF
     70
    4671 
    4772END SUBROUTINE atm2geo

  • LMDZ6/branches/Ocean_skin/libf/phylmd/calcul_divers.h

    r2825 r3605  
    11!
    2 ! $Header$
     2! $Id$
     3!
    34!
    45! Initialisations diverses au tout debut
    … …  
    1415
    1516! Calcul fin de journee : total_rain, nday_rain
    16       IF(MOD(itap,NINT(un_jour/dtime)).EQ.0) THEN
     17      IF(MOD(itap,NINT(un_jour/phys_tstep)).EQ.0) THEN
    1718!        print*,'calcul nday_rain itap ',itap
    1819         DO i = 1, klon
    … …  
    2324
    2425! Initialisation fin de mois
    25       IF(MOD(itap-itapm1,NINT(mth_len*un_jour/dtime)).EQ.0) THEN
    26         itapm1=itapm1+NINT(mth_len*un_jour/dtime)
     26      IF(MOD(itap-itapm1,NINT(mth_len*un_jour/phys_tstep)).EQ.0) THEN
     27        itapm1=itapm1+NINT(mth_len*un_jour/phys_tstep)
    2728!       print*,'initialisation itapm1 ',itapm1
    2829      ENDIF
    … …  
    3536     t2m_max_mon=0.
    3637  ENDIF
    37   IF(MOD(itap,NINT(un_jour/dtime)).EQ.1) THEN
     38  IF(MOD(itap,NINT(un_jour/phys_tstep)).EQ.1) THEN
    3839     zt2m_min_mon=zt2m
    3940     zt2m_max_mon=zt2m
    … …  
    4546     ENDDO
    4647!fin de journee
    47   IF(MOD(itap,NINT(un_jour/dtime)).EQ.0) THEN
     48  IF(MOD(itap,NINT(un_jour/phys_tstep)).EQ.0) THEN
    4849   t2m_min_mon=t2m_min_mon+zt2m_min_mon
    4950   t2m_max_mon=t2m_max_mon+zt2m_max_mon

  • LMDZ6/branches/Ocean_skin/libf/phylmd/carbon_cycle_mod.F90

    r3421 r3605  
    77!  -----------------------
    88! Control module for the carbon CO2 tracers :
    9 !   - Identification
    10 !   - Get concentrations comming from coupled model or read from file to tracers
    11 !   - Calculate new RCO2 for radiation scheme
    12 !   - Calculate new carbon flux for sending to coupled models (PISCES and ORCHIDEE)
    13 !
    14 ! Module permettant de mettre a jour les champs (puits et sources) pour le
    15 ! transport de CO2 en online (IPSL-CM et LMDZOR) et offline (lecture de carte)
     9!   - Initialisation of carbon cycle fields
     10!   - Definition of fluxes to be exchanged
     11!
     12! Rest of code is in tracco2i.F90
    1613!
    1714! Le cas online/offline est defini par le flag carbon_cycle_cpl (y/n)
    … …  
    3532  SAVE
    3633  PRIVATE
    37   PUBLIC :: carbon_cycle_init, carbon_cycle, infocfields_init
     34  PUBLIC :: carbon_cycle_init, infocfields_init
    3835
    3936! Variables read from parmeter file physiq.def
     37  LOGICAL, PUBLIC :: carbon_cycle_cpl       ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES)
     38!$OMP THREADPRIVATE(carbon_cycle_cpl)
    4039  LOGICAL, PUBLIC :: carbon_cycle_tr        ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys
    4140!$OMP THREADPRIVATE(carbon_cycle_tr)
    42   LOGICAL, PUBLIC :: carbon_cycle_cpl       ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES)
    43 !$OMP THREADPRIVATE(carbon_cycle_cpl)
     41  LOGICAL, PUBLIC :: carbon_cycle_rad       ! CO2 interactive radiatively
     42!$OMP THREADPRIVATE(carbon_cycle_rad)
    4443  INTEGER, PUBLIC :: level_coupling_esm ! Level of coupling for the ESM - 0, 1, 2, 3
    4544!$OMP THREADPRIVATE(level_coupling_esm)
     45  REAL, PUBLIC :: RCO2_glo
     46!$OMP THREADPRIVATE(RCO2_glo)
     47  REAL, PUBLIC :: RCO2_tot
     48!$OMP THREADPRIVATE(RCO2_tot)
    4649
    4750  LOGICAL :: carbon_cycle_emis_comp_omp=.FALSE.
    … …  
    7881  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_bb ! Emission from biomass burning [kgCO2/m2/s]
    7982!$OMP THREADPRIVATE(fco2_bb)
     83  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
     84!$OMP THREADPRIVATE(fco2_land)
     85  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nbp  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
     86!$OMP THREADPRIVATE(fco2_land_nbp)
     87  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nep  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
     88!$OMP THREADPRIVATE(fco2_land_nep)
     89  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fLuc  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
     90!$OMP THREADPRIVATE(fco2_land_fLuc)
     91  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fwoodharvest  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
     92!$OMP THREADPRIVATE(fco2_land_fwoodharvest)
     93  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fHarvest  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
     94!$OMP THREADPRIVATE(fco2_land_fHarvest)
     95  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocean ! Net flux from ocean [kgCO2/m2/s]
     96!$OMP THREADPRIVATE(fco2_ocean)
    8097
    8198  REAL, DIMENSION(:,:), ALLOCATABLE :: dtr_add       ! Tracer concentration to be injected
    … …  
    91108  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send ! Field allocated in phyetat0
    92109!$OMP THREADPRIVATE(co2_send)
     110
     111  INTEGER, PARAMETER, PUBLIC :: id_CO2=1              !--temporaire OB -- to be changed
    93112
    94113! nbfields : total number of fields
    … …  
    181200CONTAINS
    182201 
    183   SUBROUTINE carbon_cycle_init(tr_seri, pdtphys, aerosol, radio)
     202  SUBROUTINE carbon_cycle_init()
    184203! This subroutine is called from traclmdz_init, only at first timestep.
    185204! - Read controle parameters from .def input file
    … …  
    189208
    190209    USE dimphy
    191     USE geometry_mod, ONLY : cell_area
    192     USE mod_phys_lmdz_transfert_para
    193     USE infotrac_phy, ONLY: nbtr, nqo, niadv, tname
    194210    USE IOIPSL
    195     USE surface_data, ONLY : ok_veget, type_ocean
    196     USE phys_cal_mod, ONLY : mth_len
    197211    USE print_control_mod, ONLY: lunout
    198212
    … …  
    200214    INCLUDE "clesphys.h"
    201215 
    202 ! Input argument
    203     REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri ! Concentration Traceur [U/KgA] 
    204     REAL,INTENT(IN)                           :: pdtphys ! length of time step in physiq (sec)
    205 
    206 ! InOutput arguments
    207     LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol
    208     LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: radio
    209 
    210216! Local variables
    211     INTEGER               :: ierr, it, iiq, itc
    212     INTEGER               :: teststop
    213 
    214 ! 1) Read controle parameters from .def input file
    215 ! ------------------------------------------------
    216     ! Read fosil fuel value if no transport
    217     IF (.NOT. carbon_cycle_tr) THEN
    218 !$OMP MASTER
    219        fos_fuel_s_omp = 0.
    220        CALL getin ('carbon_cycle_fos_fuel',fos_fuel_s_omp)
    221 !$OMP END MASTER
    222 !$OMP BARRIER
    223        fos_fuel_s=fos_fuel_s_omp
    224        WRITE(lunout,*) 'carbon_cycle_fos_fuel = ', fos_fuel_s
    225     END IF
    226 
    227     ! Read parmeter for calculation compatible emission
    228     IF (.NOT. carbon_cycle_tr) THEN
    229 !$OMP MASTER
    230        carbon_cycle_emis_comp_omp=.FALSE.
    231        CALL getin('carbon_cycle_emis_comp',carbon_cycle_emis_comp_omp)
    232 !$OMP END MASTER
    233 !$OMP BARRIER
    234        carbon_cycle_emis_comp=carbon_cycle_emis_comp_omp
    235        WRITE(lunout,*) 'carbon_cycle_emis_comp = ',carbon_cycle_emis_comp
    236        IF (carbon_cycle_emis_comp) THEN
    237           CALL abort_physic('carbon_cycle_init', 'carbon_cycle_emis_comp option not yet implemented!!',1)
    238        END IF
    239     END IF
    240 
    241     ! Read parameter for interactive calculation of the CO2 value for the radiation scheme
    242 !$OMP MASTER
    243     RCO2_inter_omp=.FALSE.
    244     CALL getin('RCO2_inter',RCO2_inter_omp)
    245 !$OMP END MASTER
    246 !$OMP BARRIER
    247     RCO2_inter=RCO2_inter_omp
    248     WRITE(lunout,*) 'RCO2_inter = ', RCO2_inter
    249     IF (RCO2_inter) THEN
    250        WRITE(lunout,*) 'RCO2 will be recalculated once a day'
    251        WRITE(lunout,*) 'RCO2 initial = ', RCO2
    252     END IF
    253 
    254 
    255 ! 2) Search for carbon tracers and set default values
    256 ! ---------------------------------------------------
    257     itc=0
    258     DO it=1,nbtr
    259 !!       iiq=niadv(it+2)                                                            ! jyg
    260        iiq=niadv(it+nqo)                                                            ! jyg
    261        
    262        SELECT CASE(tname(iiq))
    263        CASE("fCO2_ocn")
    264           itc = itc + 1
    265           co2trac(itc)%name='fCO2_ocn'
    266           co2trac(itc)%id=it
    267           co2trac(itc)%file='fl_co2_ocean.nc'
    268           IF (carbon_cycle_cpl .AND. type_ocean=='couple') THEN
    269              co2trac(itc)%cpl=.TRUE.
    270              co2trac(itc)%updatefreq = 86400 ! Once a day as the coupling with OASIS/PISCES
    271           ELSE
    272              co2trac(itc)%cpl=.FALSE.
    273              co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
    274           END IF
    275        CASE("fCO2_land")
    276           itc = itc + 1
    277           co2trac(itc)%name='fCO2_land'
    278           co2trac(itc)%id=it
    279           co2trac(itc)%file='fl_co2_land.nc'
    280           IF (carbon_cycle_cpl .AND. ok_veget) THEN
    281              co2trac(itc)%cpl=.TRUE.
    282              co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE
    283           ELSE
    284              co2trac(itc)%cpl=.FALSE.
    285 !             co2trac(itc)%updatefreq = 10800   ! 10800sec = 3H
    286              co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
    287           END IF
    288        CASE("fCO2_land_use")
    289           itc = itc + 1
    290           co2trac(itc)%name='fCO2_land_use'
    291           co2trac(itc)%id=it
    292           co2trac(itc)%file='fl_co2_land_use.nc'
    293           IF (carbon_cycle_cpl .AND. ok_veget) THEN
    294              co2trac(it)%cpl=.TRUE.
    295              co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE
    296           ELSE
    297              co2trac(itc)%cpl=.FALSE.
    298              co2trac(itc)%updatefreq = 10800   ! 10800sec = 3H
    299           END IF
    300        CASE("fCO2_fos_fuel")
    301           itc = itc + 1
    302           co2trac(itc)%name='fCO2_fos_fuel'
    303           co2trac(itc)%id=it
    304           co2trac(itc)%file='fossil_fuel.nc'
    305           co2trac(itc)%cpl=.FALSE.       ! This tracer always read from file
    306 !         co2trac(itc)%updatefreq = 86400  ! 86400sec = 24H Cadule case
    307           co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
    308        CASE("fCO2_bbg")
    309           itc = itc + 1
    310           co2trac(itc)%name='fCO2_bbg'
    311           co2trac(itc)%id=it
    312           co2trac(itc)%file='fl_co2_bbg.nc'
    313           co2trac(itc)%cpl=.FALSE.       ! This tracer always read from file
    314           co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
    315        CASE("fCO2")
    316           ! fCO2 : One tracer transporting the total CO2 flux
    317           itc = itc + 1
    318           co2trac(itc)%name='fCO2'
    319           co2trac(itc)%id=it
    320           co2trac(itc)%file='fl_co2.nc'
    321           IF (carbon_cycle_cpl) THEN
    322              co2trac(itc)%cpl=.TRUE.
    323           ELSE
    324              co2trac(itc)%cpl=.FALSE.
    325           END IF
    326           co2trac(itc)%updatefreq = 86400
    327           ! DOES THIS WORK ???? Problematic due to implementation of the coupled fluxes...
    328           CALL abort_physic('carbon_cycle_init','transport of total CO2 has to be implemented and tested',1)
    329        END SELECT
    330     END DO
    331 
    332     ! Total number of carbon CO2 tracers
    333     ntr_co2 = itc
    334    
    335     ! Definition of control varaiables for the tracers
    336     DO it=1,ntr_co2
    337        aerosol(co2trac(it)%id) = .FALSE.
    338        radio(co2trac(it)%id)   = .FALSE.
    339     END DO
    340    
    341     ! Vector indicating which timestep to read for each tracer
    342     ! Always start read in the beginning of the file
    343     co2trac(:)%readstep = 0
    344    
    345 
    346 ! 3) Allocate variables
    347 ! ---------------------
    348     ! Allocate vector for storing fluxes to inject
    349     ALLOCATE(dtr_add(klon,maxco2trac), stat=ierr)
    350     IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation 11',1)       
    351    
    352     ! Allocate variables for cumulating fluxes from ORCHIDEE
    353     IF (RCO2_inter) THEN
    354        IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN
    355           ALLOCATE(fco2_land_day(klon), stat=ierr)
    356           IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation 2',1)
    357           fco2_land_day(1:klon) = 0.
    358          
    359           ALLOCATE(fco2_lu_day(klon), stat=ierr)
    360           IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation 3',1)
    361           fco2_lu_day(1:klon)   = 0.
    362        END IF
    363     END IF
    364 
    365 
    366 ! 4) Test for compatibility
    367 ! -------------------------
    368 !    IF (carbon_cycle_cpl .AND. type_ocean/='couple') THEN
    369 !       WRITE(lunout,*) 'Coupling with ocean model is needed for carbon_cycle_cpl'
    370 !       CALL abort_physic('carbon_cycle_init', 'coupled ocean is needed for carbon_cycle_cpl',1)
    371 !    END IF
    372 !
    373 !    IF (carbon_cycle_cpl .AND..NOT. ok_veget) THEN
    374 !       WRITE(lunout,*) 'Coupling with surface land model ORCHDIEE is needed for carbon_cycle_cpl'
    375 !       CALL abort_physic('carbon_cycle_init', 'ok_veget is needed for carbon_cycle_cpl',1)
    376 !    END IF
    377 
    378     ! Compiler test : following should never happen
    379     teststop=0
    380     DO it=1,teststop
    381        CALL abort_physic('carbon_cycle_init', 'Entering loop from 1 to 0',1)
    382     END DO
    383 
    384     IF (ntr_co2==0) THEN
    385        ! No carbon tracers found in tracer.def. It is not possible to do carbon cycle
    386        WRITE(lunout,*) 'No carbon tracers found in tracer.def. Not ok with carbon_cycle_tr and/or carbon_cycle_cp'
    387        CALL abort_physic('carbon_cycle_init', 'No carbon tracers found in tracer.def',1)
    388     END IF
    389    
    390 ! 5) Calculate total area of the earth surface
    391 ! --------------------------------------------
    392     CALL reduce_sum(SUM(cell_area),airetot)
    393     CALL bcast(airetot)
     217    INTEGER               :: ierr
     218
     219    IF (carbon_cycle_cpl) THEN
     220
     221       ierr=0
     222
     223       IF (.NOT.ALLOCATED(fco2_land)) ALLOCATE(fco2_land(klon), stat=ierr)
     224       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land',1)
     225       fco2_land(1:klon) = 0.
     226
     227       IF (.NOT.ALLOCATED(fco2_land_nbp)) ALLOCATE(fco2_land_nbp(klon), stat=ierr)
     228       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nbp',1)
     229       fco2_land_nbp(1:klon) = 0.
     230
     231       IF (.NOT.ALLOCATED(fco2_land_nep)) ALLOCATE(fco2_land_nep(klon), stat=ierr)
     232       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nep',1)
     233       fco2_land_nep(1:klon) = 0.
     234
     235       IF (.NOT.ALLOCATED(fco2_land_fLuc)) ALLOCATE(fco2_land_fLuc(klon), stat=ierr)
     236       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fLuc',1)
     237       fco2_land_fLuc(1:klon) = 0.
     238
     239       IF (.NOT.ALLOCATED(fco2_land_fwoodharvest)) ALLOCATE(fco2_land_fwoodharvest(klon), stat=ierr)
     240       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fwoodharvest',1)
     241       fco2_land_fwoodharvest(1:klon) = 0.
     242
     243       IF (.NOT.ALLOCATED(fco2_land_fHarvest)) ALLOCATE(fco2_land_fHarvest(klon), stat=ierr)
     244       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fHarvest',1)
     245       fco2_land_fHarvest(1:klon) = 0.
     246
     247       IF (.NOT.ALLOCATED(fco2_ff)) ALLOCATE(fco2_ff(klon), stat=ierr)
     248       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ff',1)
     249       fco2_ff(1:klon) = 0.
     250
     251       IF (.NOT.ALLOCATED(fco2_bb)) ALLOCATE(fco2_bb(klon), stat=ierr)
     252       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_bb',1)
     253       fco2_bb(1:klon) = 0.
     254
     255       IF (.NOT.ALLOCATED(fco2_ocean)) ALLOCATE(fco2_ocean(klon), stat=ierr)
     256       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ocean',1)
     257       fco2_bb(1:klon) = 0.
     258    ENDIF
    394259
    395260  END SUBROUTINE carbon_cycle_init
    396261
    397   SUBROUTINE carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source)
    398 ! Subroutine for injection of co2 in the tracers
    399 !
    400 ! - Find out if it is time to update
    401 ! - Get tracer from coupled model or from file
    402 ! - Calculate new RCO2 value for the radiation scheme
    403 ! - Calculate CO2 flux to send to ocean and land models (PISCES and ORCHIDEE)
    404 
    405     USE infotrac_phy, ONLY: nbtr
    406     USE dimphy
    407     USE mod_phys_lmdz_transfert_para
    408     USE phys_cal_mod, ONLY : mth_cur, mth_len
    409     USE phys_cal_mod, ONLY : day_cur
    410     USE indice_sol_mod
    411     USE print_control_mod, ONLY: lunout
    412     USE geometry_mod, ONLY : cell_area
    413 
    414     IMPLICIT NONE
    415 
    416     INCLUDE "clesphys.h"
    417     INCLUDE "YOMCST.h"
    418 
    419 ! In/Output arguments
    420     INTEGER,INTENT(IN) :: nstep      ! time step in physiq
    421     REAL,INTENT(IN)    :: pdtphys    ! length of time step in physiq (sec)
    422     REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf            ! Surface fraction
    423     REAL, DIMENSION(klon,klev,nbtr), INTENT(INOUT)  :: tr_seri ! All tracers
    424     REAL, DIMENSION(klon,nbtr), INTENT(INOUT)       :: source  ! Source for all tracers
    425 
    426 ! Local variables
    427     INTEGER :: it
    428     LOGICAL :: newmonth ! indicates if a new month just started
    429     LOGICAL :: newday   ! indicates if a new day just started
    430     LOGICAL :: endday   ! indicated if last time step in a day
    431 
    432     REAL, PARAMETER :: fact=1.E-15/2.12  ! transformation factor from gC/m2/day => ppm/m2/day
    433     REAL, DIMENSION(klon) :: fco2_tmp
    434     REAL :: sumtmp
    435     REAL :: delta_co2_ppm
    436    
    437 
    438 ! 1) Calculate logicals indicating if it is a new month, new day or the last time step in a day (end day)
    439 ! -------------------------------------------------------------------------------------------------------
    440 
    441     newday = .FALSE.; endday = .FALSE.; newmonth = .FALSE.
    442 
    443     IF (MOD(nstep,INT(86400./pdtphys))==1) newday=.TRUE.
    444     IF (MOD(nstep,INT(86400./pdtphys))==0) endday=.TRUE.
    445     IF (newday .AND. day_cur==1) newmonth=.TRUE.
    446 
    447 ! 2)  For each carbon tracer find out if it is time to inject (update)
    448 ! --------------------------------------------------------------------
    449     DO it = 1, ntr_co2
    450        IF ( MOD(nstep,INT(co2trac(it)%updatefreq/pdtphys)) == 1 ) THEN
    451           co2trac(it)%updatenow = .TRUE.
    452        ELSE
    453           co2trac(it)%updatenow = .FALSE.
    454        END IF
    455     END DO
    456 
    457 ! 3) Get tracer update
    458 ! --------------------------------------
    459     DO it = 1, ntr_co2
    460        IF ( co2trac(it)%updatenow ) THEN
    461           IF ( co2trac(it)%cpl ) THEN
    462              ! Get tracer from coupled model
    463              SELECT CASE(co2trac(it)%name)
    464              CASE('fCO2_land')     ! from ORCHIDEE
    465                 dtr_add(:,it) = fco2_land_inst(:)*pctsrf(:,is_ter)*fact ! [ppm/m2/day]
    466              CASE('fCO2_land_use') ! from ORCHIDEE
    467                 dtr_add(:,it) = fco2_lu_inst(:)  *pctsrf(:,is_ter)*fact ! [ppm/m2/day]
    468              CASE('fCO2_ocn')      ! from PISCES
    469                 dtr_add(:,it) = fco2_ocn_day(:)  *pctsrf(:,is_oce)*fact ! [ppm/m2/day]
    470              CASE DEFAULT
    471                 WRITE(lunout,*) 'Error with tracer ',co2trac(it)%name
    472                 CALL abort_physic('carbon_cycle', 'No coupling implemented for this tracer',1)
    473              END SELECT
    474           ELSE
    475              ! Read tracer from file
    476              co2trac(it)%readstep = co2trac(it)%readstep + 1 ! increment time step in file
    477 ! Patricia   CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.FALSE.,dtr_add(:,it))
    478              CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.TRUE.,dtr_add(:,it))
    479 
    480              ! Converte from kgC/m2/h to kgC/m2/s
    481              dtr_add(:,it) = dtr_add(:,it)/3600
    482              ! Add individual treatment of values read from file
    483              SELECT CASE(co2trac(it)%name)
    484              CASE('fCO2_land')
    485                 dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter)
    486              CASE('fCO2_land_use')
    487                 dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter)
    488              CASE('fCO2_ocn')
    489                 dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_oce)
    490 ! Patricia :
    491 !             CASE('fCO2_fos_fuel')
    492 !                dtr_add(:,it) = dtr_add(:,it)/mth_len
    493 !                co2trac(it)%readstep = 0 ! Always read same value for fossil fuel(Cadule case)
    494              END SELECT
    495           END IF
    496        END IF
    497     END DO
    498 
    499 ! 4) Update co2 tracers :
    500 !    Loop over all carbon tracers and add source
    501 ! ------------------------------------------------------------------
    502     IF (carbon_cycle_tr) THEN
    503        DO it = 1, ntr_co2
    504           IF (.FALSE.) THEN
    505              tr_seri(1:klon,1,co2trac(it)%id) = tr_seri(1:klon,1,co2trac(it)%id) + dtr_add(1:klon,it)
    506              source(1:klon,co2trac(it)%id) = 0.
    507           ELSE
    508              source(1:klon,co2trac(it)%id) = dtr_add(1:klon,it)
    509           END IF
    510        END DO
    511     END IF
    512 
    513 
    514 ! 5) Calculations for new CO2 value for the radiation scheme(instead of reading value from .def)
    515 ! ----------------------------------------------------------------------------------------------
    516     IF (RCO2_inter) THEN
    517        ! Cumulate fluxes from ORCHIDEE at each timestep
    518        IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN
    519           IF (newday) THEN ! Reset cumulative variables once a day
    520              fco2_land_day(1:klon) = 0.
    521              fco2_lu_day(1:klon)   = 0.
    522           END IF
    523           fco2_land_day(1:klon) = fco2_land_day(1:klon) + fco2_land_inst(1:klon) ![gC/m2/day]
    524           fco2_lu_day(1:klon)   = fco2_lu_day(1:klon)   + fco2_lu_inst(1:klon)   ![gC/m2/day]
    525        END IF
    526 
    527        ! At the end of a new day, calculate a mean scalare value of CO2
    528        ! JG : Ici on utilise uniquement le traceur du premier couche du modele. Est-ce que c'est correcte ?
    529        IF (endday) THEN
    530 
    531           IF (carbon_cycle_tr) THEN
    532              ! Sum all co2 tracers to get the total delta CO2 flux
    533              fco2_tmp(:) = 0.
    534              DO it = 1, ntr_co2
    535                 fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id)
    536              END DO
    537              
    538           ELSE IF (carbon_cycle_cpl) THEN ! no carbon_cycle_tr
    539              ! Sum co2 fluxes comming from coupled models and parameter for fossil fuel
    540              fco2_tmp(1:klon) = fos_fuel_s + ((fco2_lu_day(1:klon) + fco2_land_day(1:klon))*pctsrf(1:klon,is_ter) &
    541                   + fco2_ocn_day(:)*pctsrf(:,is_oce)) * fact
    542           END IF
    543 
    544           ! Calculate a global mean value of delta CO2 flux
    545           fco2_tmp(1:klon) = fco2_tmp(1:klon) * cell_area(1:klon)
    546           CALL reduce_sum(SUM(fco2_tmp),sumtmp)
    547           CALL bcast(sumtmp)
    548           delta_co2_ppm = sumtmp/airetot
    549          
    550           ! Add initial value for co2_ppm and delta value
    551           co2_ppm = co2_ppm0 + delta_co2_ppm
    552          
    553           ! Transformation of atmospheric CO2 concentration for the radiation code
    554           RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97
    555          
    556           WRITE(lunout,*) 'RCO2 is now updated! RCO2 = ', RCO2
    557        END IF ! endday
    558 
    559     END IF ! RCO2_inter
    560 
    561 
    562 ! 6) Calculate CO2 flux to send to ocean and land models : PISCES and ORCHIDEE         
    563 ! ----------------------------------------------------------------------------
    564     IF (carbon_cycle_cpl) THEN
    565 
    566        IF (carbon_cycle_tr) THEN
    567           ! Sum all co2 tracers to get the total delta CO2 flux at first model layer
    568           fco2_tmp(:) = 0.
    569           DO it = 1, ntr_co2
    570              fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id)
    571           END DO
    572           co2_send(1:klon) = fco2_tmp(1:klon) + co2_ppm0
    573        ELSE
    574           ! Send a scalare value in 2D variable to ocean and land model (PISCES and ORCHIDEE)
    575           co2_send(1:klon) = co2_ppm
    576        END IF
    577 
    578     END IF
    579 
    580   END SUBROUTINE carbon_cycle
    581  
    582262  SUBROUTINE infocfields_init
    583263
    584     USE control_mod, ONLY: planet_type
     264!    USE control_mod, ONLY: planet_type
    585265    USE phys_cal_mod, ONLY : mth_cur
    586266    USE mod_synchro_omp
    … …  
    656336
    657337  CHARACTER(len=*),parameter :: modname="infocfields"
     338
     339  CHARACTER(len=10),SAVE :: planet_type="earth"
    658340
    659341!-----------------------------------------------------------------------
    … …  
    718400                  WRITE(lunout,*) 'abort_gcm --- nbcf_in : ',nbcf_in
    719401                  WRITE(lunout,*) 'abort_gcm --- nbcf_out: ',nbcf_out
    720                   CALL abort_gcm('infocfields_init','Problem in the definition of the coupling fields',1)
     402                  CALL abort_physic('infocfields_init','Problem in the definition of the coupling fields',1)
    721403               ENDIF
    722404             ENDDO !DO iq=1,nbcf
    … …  
    836518
    837519 ALLOCATE(fields_in(klon,nbcf_in),stat=error)
    838  IF (error /= 0)  CALL abort_gcm(modname,'Pb in allocation fields_in',1)
     520 IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation fields_in',1)
    839521 ALLOCATE(yfields_in(klon,nbcf_in),stat=error)
    840  IF (error /= 0)  CALL abort_gcm(modname,'Pb in allocation yfields_in',1)
     522 IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation yfields_in',1)
    841523 ALLOCATE(fields_out(klon,nbcf_out),stat=error)
    842  IF (error /= 0)  CALL abort_gcm(modname,'Pb in allocation fields_out',1)
     524 IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation fields_out',1)
    843525 ALLOCATE(yfields_out(klon,nbcf_out),stat=error)
    844  IF (error /= 0)  CALL abort_gcm(modname,'Pb in allocation yfields_out',1)
     526 IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation yfields_out',1)
    845527
    846528END SUBROUTINE infocfields_init

  • LMDZ6/branches/Ocean_skin/libf/phylmd/clesphys.h

    r3327 r3605  
    7070!IM freq_outNMC : frequences de sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC)
    7171!IM freq_calNMC : frequences de calcul fis. hist*NMC.nc
    72 !IM pasphys : pas de temps de physique (secondes)
    73        REAL pasphys
    7472       LOGICAL ok_histNMC(3)
    7573       INTEGER levout_histNMC(3)
    … …  
    111109     &     , min_wind_speed,f_gust_wk,f_gust_bl,f_qsat_oce,f_z0qh_oce   &
    112110     &     , z0m_seaice,z0h_seaice                                      &
    113      &     , pasphys            , freq_outNMC, freq_calNMC              &
     111     &     , freq_outNMC, freq_calNMC                                   &
    114112     &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
    115113     &     , freq_ISCCP, ecrit_ISCCP, freq_COSP, freq_AIRS              &

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cloudth_mod.F90

    r2960 r3605  
    77       SUBROUTINE cloudth(ngrid,klev,ind2,  &
    88     &           ztv,po,zqta,fraca, &
    9      &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
     9     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
    1010     &           ratqs,zqs,t)
    1111
    … …  
    3838      REAL zpspsk(ngrid,klev)
    3939      REAL paprs(ngrid,klev+1)
     40      REAL pplay(ngrid,klev)
    4041      REAL ztla(ngrid,klev)
    4142      REAL zthl(ngrid,klev)
    … …  
    7879      CALL cloudth_vert(ngrid,klev,ind2,  &
    7980     &           ztv,po,zqta,fraca, &
    80      &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
     81     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
    8182     &           ratqs,zqs,t)
    8283      RETURN
    … …  
    251252     SUBROUTINE cloudth_vert(ngrid,klev,ind2,  &
    252253     &           ztv,po,zqta,fraca, &
    253      &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
     254     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
    254255     &           ratqs,zqs,t)
    255256
    … …  
    282283      REAL zpspsk(ngrid,klev)
    283284      REAL paprs(ngrid,klev+1)
     285      REAL pplay(ngrid,klev)
    284286      REAL ztla(ngrid,klev)
    285287      REAL zthl(ngrid,klev)
    … …  
    585587END SUBROUTINE cloudth_vert
    586588
     589
     590
     591
    587592       SUBROUTINE cloudth_v3(ngrid,klev,ind2,  &
    588593     &           ztv,po,zqta,fraca, &
    589      &           qcloud,ctot,ctot_vol,zpspsk,paprs,ztla,zthl, &
     594     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
    590595     &           ratqs,zqs,t)
    591596
    … …  
    618623      REAL zpspsk(ngrid,klev)
    619624      REAL paprs(ngrid,klev+1)
     625      REAL pplay(ngrid,klev)
    620626      REAL ztla(ngrid,klev)
    621627      REAL zthl(ngrid,klev)
    … …  
    641647      REAL alth,alenv,ath,aenv
    642648      REAL sth,senv,sigma1s,sigma2s,xth,xenv, exp_xenv1, exp_xenv2,exp_xth1,exp_xth2
     649      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
    643650      REAL Tbef,zdelta,qsatbef,zcor
    644651      REAL qlbef 
    … …  
    654661      CALL cloudth_vert_v3(ngrid,klev,ind2,  &
    655662     &           ztv,po,zqta,fraca, &
    656      &           qcloud,ctot,ctot_vol,zpspsk,paprs,ztla,zthl, &
     663     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
    657664     &           ratqs,zqs,t)
    658665      RETURN
    … …  
    808815     SUBROUTINE cloudth_vert_v3(ngrid,klev,ind2,  &
    809816     &           ztv,po,zqta,fraca, &
    810      &           qcloud,ctot,ctot_vol,zpspsk,paprs,ztla,zthl, &
     817     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
    811818     &           ratqs,zqs,t)
    812819
    … …  
    841848      REAL zpspsk(ngrid,klev)
    842849      REAL paprs(ngrid,klev+1)
     850      REAL pplay(ngrid,klev)
    843851      REAL ztla(ngrid,klev)
    844852      REAL zthl(ngrid,klev)
    … …  
    864872      REAL alth,alenv,ath,aenv
    865873      REAL sth,senv,sigma1s,sigma2s,sigma1s_fraca,sigma1s_ratqs
     874      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
    866875      REAL xth,xenv,exp_xenv1,exp_xenv2,exp_xth1,exp_xth2
    867876      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
    … …  
    876885      REAL,SAVE :: sigma1s_factor=1.1
    877886      REAL,SAVE :: sigma1s_power=0.6
     887      REAL,SAVE :: sigma2s_factor=0.09
     888      REAL,SAVE :: sigma2s_power=0.5
    878889      REAL,SAVE :: cloudth_ratqsmin=-1.
    879       !$OMP THREADPRIVATE(sigma1s_factor,sigma1s_power,cloudth_ratqsmin)
     890      !$OMP THREADPRIVATE(sigma1s_factor,sigma1s_power,sigma2s_factor,sigma2s_power,cloudth_ratqsmin)
    880891      INTEGER, SAVE :: iflag_cloudth_vert_noratqs=0
    881892      !$OMP THREADPRIVATE(iflag_cloudth_vert_noratqs)
    … …  
    888899      REAL zqs(ngrid), qcloud(ngrid)
    889900      REAL erf
     901
     902      REAL rhodz(ngrid,klev)
     903      REAL zrho(ngrid,klev)
     904      REAL dz(ngrid,klev)
     905
     906      DO ind1 = 1, ngrid
     907        !Layer calculation
     908        rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg !kg/m2
     909        zrho(ind1,ind2) = pplay(ind1,ind2)/t(ind1,ind2)/rd !kg/m3
     910        dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2) !m : epaisseur de la couche en metre
     911      END DO
     912
    890913
    891914!------------------------------------------------------------------------------
    … …  
    930953        CALL getin_p('cloudth_sigma1s_power',sigma1s_power)
    931954        WRITE(*,*) 'cloudth_sigma1s_power = ', sigma1s_power
     955        ! Factor used in the calculation of sigma2s
     956        CALL getin_p('cloudth_sigma2s_factor',sigma2s_factor)
     957        WRITE(*,*) 'cloudth_sigma2s_factor = ', sigma2s_factor
     958        ! Power used in the calculation of sigma2s
     959        CALL getin_p('cloudth_sigma2s_power',sigma2s_power)
     960        WRITE(*,*) 'cloudth_sigma2s_power = ', sigma2s_power
    932961        ! Minimum value for the environmental air subgrid water distrib
    933962        CALL getin_p('cloudth_ratqsmin',cloudth_ratqsmin)
    … …  
    9981027      ENDIF
    9991028      sigma1s = sigma1s_fraca + sigma1s_ratqs
    1000       sigma2s=(0.09*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**0.5))+0.002*zqta(ind1,ind2)
     1029      sigma2s=(sigma2s_factor*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**sigma2s_power))+0.002*zqta(ind1,ind2)
    10011030!      tests
    10021031!      sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
    … …  
    10501079
    10511080      ELSE IF (iflag_cloudth_vert >= 3) THEN
    1052 
     1081      IF (iflag_cloudth_vert < 5) THEN
    10531082!-------------------------------------------------------------------------------
    10541083!  Version 3: Changes by J. Jouhaud; condensation for q > -delta s
    … …  
    11191148      endif
    11201149
    1121 
    11221150      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
    11231151      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
    11241152
     1153      ELSE IF (iflag_cloudth_vert == 5) THEN
     1154      sigma1s=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5)+ratqs(ind1,ind2)*po(ind1) !Environment
     1155      sigma2s=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.02)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2)                   !Thermals
     1156      !sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
     1157      !sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2)
     1158      xth=sth/(sqrt(2.)*sigma2s)
     1159      xenv=senv/(sqrt(2.)*sigma1s)
     1160
     1161      !Volumique
     1162      cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth))
     1163      cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
     1164      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
     1165      !print *,'jeanjean_CV=',ctot_vol(ind1,ind2)
     1166
     1167      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth_vol(ind1,ind2))
     1168      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv_vol(ind1,ind2)) 
     1169      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
     1170
     1171      !Surfacique
     1172      !Neggers
     1173      !beta=0.0044
     1174      !inverse_rho=1.+beta*dz(ind1,ind2)
     1175      !print *,'jeanjean : beta=',beta
     1176      !cth(ind1,ind2)=cth_vol(ind1,ind2)*inverse_rho
     1177      !cenv(ind1,ind2)=cenv_vol(ind1,ind2)*inverse_rho
     1178      !ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
     1179
     1180      !Brooks
     1181      a_Brooks=0.6694
     1182      b_Brooks=0.1882
     1183      A_Maj_Brooks=0.1635 !-- sans shear
     1184      !A_Maj_Brooks=0.17   !-- ARM LES
     1185      !A_Maj_Brooks=0.18   !-- RICO LES
     1186      !A_Maj_Brooks=0.19   !-- BOMEX LES
     1187      Dx_Brooks=200000.
     1188      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
     1189      !print *,'jeanjean_f=',f_Brooks
     1190
     1191      cth(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cth_vol(ind1,ind2),1.)))- 1.))
     1192      cenv(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cenv_vol(ind1,ind2),1.)))- 1.))
     1193      ctot(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
     1194      !print *,'JJ_ctot_1',ctot(ind1,ind2)
     1195
     1196
     1197
     1198
     1199
     1200      ENDIF ! of if (iflag_cloudth_vert<5)
    11251201      ENDIF ! of if (iflag_cloudth_vert==1 or 3 or 4)
    11261202
    1127 
     1203!      if (ctot(ind1,ind2).lt.1.e-10) then
    11281204      if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then
    11291205      ctot(ind1,ind2)=0.
    11301206      ctot_vol(ind1,ind2)=0.
    1131       qcloud(ind1)=zqsatenv(ind1,ind2) 
    1132 
    1133       else 
     1207      qcloud(ind1)=zqsatenv(ind1,ind2)
     1208
     1209      else
    11341210               
    11351211      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
    … …  
    11391215      endif 
    11401216
    1141       else  ! Environment only
     1217      else  ! gaussienne environnement seule
    11421218     
    11431219      zqenv(ind1)=po(ind1)
    … …  
    11511227     
    11521228
    1153 !     qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
     1229!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
    11541230      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
    1155       alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) 
     1231      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)
    11561232      aenv=1./(1.+(alenv*Lv/cppd))
    11571233      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
    11581234      sth=0.
     1235     
    11591236
    11601237      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
    11611238      sigma2s=0.
    11621239
    1163       xenv=senv/(sqrt2*sigma1s)
     1240      sqrt2pi=sqrt(2.*pi)
     1241      xenv=senv/(sqrt(2.)*sigma1s)
    11641242      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
    11651243      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
    1166       qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv(ind1,ind2))
     1244      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
    11671245     
    11681246      if (ctot(ind1,ind2).lt.1.e-3) then
    11691247      ctot(ind1,ind2)=0.
    1170       qcloud(ind1)=zqsatenv(ind1,ind2) 
     1248      qcloud(ind1)=zqsatenv(ind1,ind2)
    11711249
    11721250      else   
    11731251               
     1252!      ctot(ind1,ind2)=ctot(ind1,ind2)
    11741253      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
    11751254
    1176       endif   
    1177  
     1255      endif 
     1256 
     1257
     1258
     1259
    11781260      endif       ! From the separation (thermal/envrionnement) et (environnement) only, l.335 et l.492
    11791261      ! Outputs used to check the PDFs
    … …  
    11841266
    11851267      enddo       ! from the loop on ngrid l.333
    1186      
    11871268      return
    11881269!     end
    11891270END SUBROUTINE cloudth_vert_v3
    11901271!
     1272
     1273
     1274
     1275
     1276
     1277
     1278
     1279
     1280
     1281
     1282
     1283       SUBROUTINE cloudth_v6(ngrid,klev,ind2,  &
     1284     &           ztv,po,zqta,fraca, &
     1285     &           qcloud,ctot_surf,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
     1286     &           ratqs,zqs,T)
     1287
     1288
     1289      USE ioipsl_getin_p_mod, ONLY : getin_p
     1290      USE phys_output_var_mod, ONLY : cloudth_sth,cloudth_senv, &
     1291     &                                cloudth_sigmath,cloudth_sigmaenv
     1292
     1293      IMPLICIT NONE
     1294
     1295#include "YOMCST.h"
     1296#include "YOETHF.h"
     1297#include "FCTTRE.h"
     1298#include "thermcell.h"
     1299#include "nuage.h"
     1300
     1301
     1302        !Domain variables
     1303      INTEGER ngrid !indice Max lat-lon
     1304      INTEGER klev  !indice Max alt
     1305      INTEGER ind1  !indice in [1:ngrid]
     1306      INTEGER ind2  !indice in [1:klev]
     1307        !thermal plume fraction
     1308      REAL fraca(ngrid,klev+1)   !thermal plumes fraction in the gridbox
     1309        !temperatures
     1310      REAL T(ngrid,klev)       !temperature
     1311      REAL zpspsk(ngrid,klev)  !factor (p/p0)**kappa (used for potential variables)
     1312      REAL ztv(ngrid,klev)     !potential temperature (voir thermcell_env.F90)
     1313      REAL ztla(ngrid,klev)    !liquid temperature in the thermals (Tl_th)
     1314      REAL zthl(ngrid,klev)    !liquid temperature in the environment (Tl_env)
     1315        !pressure
     1316      REAL paprs(ngrid,klev+1)   !pressure at the interface of levels
     1317      REAL pplay(ngrid,klev)     !pressure at the middle of the level
     1318        !humidity
     1319      REAL ratqs(ngrid,klev)   !width of the total water subgrid-scale distribution
     1320      REAL po(ngrid)           !total water (qt)
     1321      REAL zqenv(ngrid)        !total water in the environment (qt_env)
     1322      REAL zqta(ngrid,klev)    !total water in the thermals (qt_th)
     1323      REAL zqsatth(ngrid,klev)   !water saturation level in the thermals (q_sat_th)
     1324      REAL zqsatenv(ngrid,klev)  !water saturation level in the environment (q_sat_env)
     1325      REAL qlth(ngrid,klev)    !condensed water in the thermals
     1326      REAL qlenv(ngrid,klev)   !condensed water in the environment
     1327      REAL qltot(ngrid,klev)   !condensed water in the gridbox
     1328        !cloud fractions
     1329      REAL cth_vol(ngrid,klev)   !cloud fraction by volume in the thermals
     1330      REAL cenv_vol(ngrid,klev)  !cloud fraction by volume in the environment
     1331      REAL ctot_vol(ngrid,klev)  !cloud fraction by volume in the gridbox
     1332      REAL cth_surf(ngrid,klev)  !cloud fraction by surface in the thermals
     1333      REAL cenv_surf(ngrid,klev) !cloud fraction by surface in the environment 
     1334      REAL ctot_surf(ngrid,klev) !cloud fraction by surface in the gridbox
     1335        !PDF of saturation deficit variables
     1336      REAL rdd,cppd,Lv
     1337      REAL Tbef,zdelta,qsatbef,zcor
     1338      REAL alth,alenv,ath,aenv
     1339      REAL sth,senv              !saturation deficits in the thermals and environment
     1340      REAL sigma_env,sigma_th    !standard deviations of the biGaussian PDF
     1341        !cloud fraction variables
     1342      REAL xth,xenv
     1343      REAL inverse_rho,beta                                  !Neggers et al. (2011) method
     1344      REAL a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks !Brooks et al. (2005) method
     1345        !Incloud total water variables
     1346      REAL zqs(ngrid)    !q_sat
     1347      REAL qcloud(ngrid) !eau totale dans le nuage
     1348        !Some arithmetic variables
     1349      REAL erf,pi,sqrt2,sqrt2pi
     1350        !Depth of the layer
     1351      REAL dz(ngrid,klev)    !epaisseur de la couche en metre
     1352      REAL rhodz(ngrid,klev)
     1353      REAL zrho(ngrid,klev)
     1354      DO ind1 = 1, ngrid
     1355        rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg ![kg/m2]
     1356        zrho(ind1,ind2) = pplay(ind1,ind2)/T(ind1,ind2)/rd          ![kg/m3]
     1357        dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2)            ![m]
     1358      END DO
     1359
     1360!------------------------------------------------------------------------------
     1361! Initialization
     1362!------------------------------------------------------------------------------
     1363      qlth(:,:)=0.
     1364      qlenv(:,:)=0. 
     1365      qltot(:,:)=0.
     1366      cth_vol(:,:)=0.
     1367      cenv_vol(:,:)=0.
     1368      ctot_vol(:,:)=0.
     1369      cth_surf(:,:)=0.
     1370      cenv_surf(:,:)=0.
     1371      ctot_surf(:,:)=0.
     1372      qcloud(:)=0.
     1373      rdd=287.04
     1374      cppd=1005.7
     1375      pi=3.14159
     1376      Lv=2.5e6
     1377      sqrt2=sqrt(2.)
     1378      sqrt2pi=sqrt(2.*pi)
     1379
     1380
     1381      DO ind1=1,ngrid
     1382!-------------------------------------------------------------------------------
     1383!Both thermal and environment in the gridbox
     1384!-------------------------------------------------------------------------------
     1385      IF ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) THEN
     1386        !--------------------------------------------
     1387        !calcul de qsat_env
     1388        !--------------------------------------------
     1389      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
     1390      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
     1391      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
     1392      qsatbef=MIN(0.5,qsatbef)
     1393      zcor=1./(1.-retv*qsatbef)
     1394      qsatbef=qsatbef*zcor
     1395      zqsatenv(ind1,ind2)=qsatbef
     1396        !--------------------------------------------
     1397        !calcul de s_env
     1398        !--------------------------------------------
     1399      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84 these Arnaud Jam
     1400      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84 these Arnaud Jam
     1401      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84 these Arnaud Jam
     1402        !--------------------------------------------
     1403        !calcul de qsat_th
     1404        !--------------------------------------------
     1405      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
     1406      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
     1407      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
     1408      qsatbef=MIN(0.5,qsatbef)
     1409      zcor=1./(1.-retv*qsatbef)
     1410      qsatbef=qsatbef*zcor
     1411      zqsatth(ind1,ind2)=qsatbef
     1412        !--------------------------------------------
     1413        !calcul de s_th 
     1414        !--------------------------------------------
     1415      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84 these Arnaud Jam
     1416      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84 these Arnaud Jam
     1417      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84 these Arnaud Jam
     1418        !--------------------------------------------
     1419        !calcul standard deviations bi-Gaussian PDF
     1420        !--------------------------------------------
     1421      sigma_th=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.01)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2)
     1422      sigma_env=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5)+ratqs(ind1,ind2)*po(ind1)
     1423      xth=sth/(sqrt2*sigma_th)
     1424      xenv=senv/(sqrt2*sigma_env)
     1425        !--------------------------------------------
     1426        !Cloud fraction by volume CF_vol
     1427        !--------------------------------------------
     1428      cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth))
     1429      cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
     1430      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
     1431        !--------------------------------------------
     1432        !Condensed water qc
     1433        !--------------------------------------------
     1434      qlth(ind1,ind2)=sigma_th*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt2*cth_vol(ind1,ind2))
     1435      qlenv(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv_vol(ind1,ind2)) 
     1436      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
     1437        !--------------------------------------------
     1438        !Cloud fraction by surface CF_surf
     1439        !--------------------------------------------
     1440        !Method Neggers et al. (2011) : ok for cumulus clouds only
     1441      !beta=0.0044 (Jouhaud et al.2018)
     1442      !inverse_rho=1.+beta*dz(ind1,ind2)
     1443      !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho
     1444        !Method Brooks et al. (2005) : ok for all types of clouds
     1445      a_Brooks=0.6694
     1446      b_Brooks=0.1882
     1447      A_Maj_Brooks=0.1635 !-- sans dependence au cisaillement de vent
     1448      Dx_Brooks=200000.   !-- si l'on considere des mailles de 200km de cote
     1449      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
     1450      ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
     1451        !--------------------------------------------
     1452        !Incloud Condensed water qcloud
     1453        !--------------------------------------------
     1454      if (ctot_surf(ind1,ind2) .lt. 1.e-10) then
     1455      ctot_vol(ind1,ind2)=0.
     1456      ctot_surf(ind1,ind2)=0.
     1457      qcloud(ind1)=zqsatenv(ind1,ind2)
     1458      else
     1459      qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqs(ind1)
     1460      endif
     1461
     1462
     1463
     1464!-------------------------------------------------------------------------------
     1465!Environment only in the gridbox
     1466!-------------------------------------------------------------------------------
     1467      ELSE
     1468        !--------------------------------------------
     1469        !calcul de qsat_env
     1470        !--------------------------------------------
     1471      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
     1472      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
     1473      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
     1474      qsatbef=MIN(0.5,qsatbef)
     1475      zcor=1./(1.-retv*qsatbef)
     1476      qsatbef=qsatbef*zcor
     1477      zqsatenv(ind1,ind2)=qsatbef
     1478        !--------------------------------------------
     1479        !calcul de s_env
     1480        !--------------------------------------------
     1481      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84 these Arnaud Jam
     1482      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84 these Arnaud Jam
     1483      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84 these Arnaud Jam
     1484        !--------------------------------------------
     1485        !calcul standard deviations Gaussian PDF
     1486        !--------------------------------------------
     1487      zqenv(ind1)=po(ind1)
     1488      sigma_env=ratqs(ind1,ind2)*zqenv(ind1)
     1489      xenv=senv/(sqrt2*sigma_env)
     1490        !--------------------------------------------
     1491        !Cloud fraction by volume CF_vol
     1492        !--------------------------------------------
     1493      ctot_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
     1494        !--------------------------------------------
     1495        !Condensed water qc
     1496        !--------------------------------------------
     1497      qltot(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*ctot_vol(ind1,ind2))
     1498        !--------------------------------------------
     1499        !Cloud fraction by surface CF_surf
     1500        !--------------------------------------------
     1501        !Method Neggers et al. (2011) : ok for cumulus clouds only
     1502      !beta=0.0044 (Jouhaud et al.2018)
     1503      !inverse_rho=1.+beta*dz(ind1,ind2)
     1504      !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho
     1505        !Method Brooks et al. (2005) : ok for all types of clouds
     1506      a_Brooks=0.6694
     1507      b_Brooks=0.1882
     1508      A_Maj_Brooks=0.1635 !-- sans dependence au shear
     1509      Dx_Brooks=200000.
     1510      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
     1511      ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
     1512        !--------------------------------------------
     1513        !Incloud Condensed water qcloud
     1514        !--------------------------------------------
     1515      if (ctot_surf(ind1,ind2) .lt. 1.e-8) then
     1516      ctot_vol(ind1,ind2)=0.
     1517      ctot_surf(ind1,ind2)=0.
     1518      qcloud(ind1)=zqsatenv(ind1,ind2)
     1519      else
     1520      qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqsatenv(ind1,ind2)
     1521      endif
     1522
     1523
     1524      END IF  ! From the separation (thermal/envrionnement) et (environnement only)
     1525
     1526      ! Outputs used to check the PDFs
     1527      cloudth_senv(ind1,ind2) = senv
     1528      cloudth_sth(ind1,ind2) = sth
     1529      cloudth_sigmaenv(ind1,ind2) = sigma_env
     1530      cloudth_sigmath(ind1,ind2) = sigma_th
     1531
     1532      END DO  ! From the loop on ngrid
     1533      return
     1534
     1535END SUBROUTINE cloudth_v6
    11911536END MODULE cloudth_mod
     1537
     1538
     1539
     1540

  • LMDZ6/branches/Ocean_skin/libf/phylmd/coef_diff_turb_mod.F90

    r3102 r3605  
    6565
    6666
     67    ykmm = 0 !ym missing init
     68    ykmn = 0 !ym missing init
     69    ykmq = 0 !ym missing init
     70   
     71   
    6772!****************************************************************************************   
    6873! Calcul de coefficients de diffusion turbulent de l'atmosphere :
    … …  
    177182       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
    178183               
     184    ELSE
     185       ! No TKE for Standard Physics
     186       yq2=0.
    179187    ENDIF !(iflag_pbl.ge.3)
    180188

  • LMDZ6/branches/Ocean_skin/libf/phylmd/concvl.F90

    r3197 r3605  
    1313!RomP >>>
    1414!!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
    15                   da, phi, mp, phii, d1a, dam, sij, clw, elij, &     ! RomP
     15                  da, phi, mp, phii, d1a, dam, sij, qta, clw, elij, &! RomP
    1616                  dd_t, dd_q, lalim_conv, wght_th, &                 ! RomP
    1717                  evap, ep, epmlmMm, eplaMm, &                       ! RomP
    18                   wdtrainA, wdtrainM, wght, qtc, sigt, &
     18                  wdtrainA, wdtrainS, wdtrainM, wght, qtc, sigt, &
    1919                  tau_cld_cv, coefw_cld_cv, &                           ! RomP+RL, AJ
    2020!RomP <<<
    … …  
    8080! eplaMm-----output-R
    8181! wdtrainA---output-R
     82! wdtrainS---output-R
    8283! wdtrainM---output-R
    8384! wght-------output-R
    … …  
    134135  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: d1a, dam
    135136  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: sij, elij
     137  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qta
    136138  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: clw
    137139  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: dd_t, dd_q
    … …  
    139141  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: eplaMm
    140142  REAL, DIMENSION(klon,klev,klev), INTENT(OUT)  :: epmlmMm
    141   REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wdtrainA, wdtrainM
     143  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wdtrainA, wdtrainS, wdtrainM
    142144! RomP <<<
    143145  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wght                       !RL
    … …  
    437439!!                   evap,ep,epmlmMm,eplaMm,                              ! RomP
    438440                    da, phi, mp, phii, d1a, dam, sij, wght, &           ! RomP+RL
    439                     clw, elij, evap, ep, epmlmMm, eplaMm, &             ! RomP+RL
    440                     wdtrainA, wdtrainM, qtc, sigt, &
     441                    qta, clw, elij, evap, ep, epmlmMm, eplaMm, &        ! RomP+RL
     442                    wdtrainA, wdtrainS, wdtrainM, qtc, sigt, &
    441443                    tau_cld_cv, coefw_cld_cv, &                         ! RomP,AJ
    442444!AC!+!RomP+jyg

  • LMDZ6/branches/Ocean_skin/libf/phylmd/conf_phys_m.F90

    r3432 r3605  
    1717       iflag_cld_th, &
    1818       iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
    19        ok_ade, ok_aie, ok_alw, ok_cdnc, aerosol_couple, chemistry_couple, &
     19       ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, aerosol_couple, chemistry_couple, &
    2020       flag_aerosol, flag_aerosol_strat, flag_aer_feedback, new_aod, &
    2121       flag_bc_internal_mixture, bl95_b0, bl95_b1,&
    … …  
    2626    USE surface_data
    2727    USE phys_cal_mod
    28     USE carbon_cycle_mod,  ONLY: carbon_cycle_tr, carbon_cycle_cpl, level_coupling_esm
     28    USE carbon_cycle_mod,  ONLY: carbon_cycle_tr, carbon_cycle_cpl, carbon_cycle_rad, level_coupling_esm
    2929    USE mod_grid_phy_lmdz, ONLY: klon_glo
    3030    USE print_control_mod, ONLY: lunout
    3131    use config_ocean_skin_m, only: config_ocean_skin
     32    USE phys_state_var_mod, ONLY: phys_tstep
    3233
    3334    INCLUDE "conema3.h"
    … …  
    6364    ! flag_bc_internal_mixture : use BC internal mixture if true
    6465    ! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc
     66    ! ok_volcan: activate volcanic diags (SW heat & LW cool rate, SW & LW flux)
    6567    !
    6668
    … …  
    7173    LOGICAL              :: ok_LES
    7274    LOGICAL              :: callstats
    73     LOGICAL              :: ok_ade, ok_aie, ok_alw, ok_cdnc
     75    LOGICAL              :: ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan
    7476    LOGICAL              :: aerosol_couple, chemistry_couple
    7577    INTEGER              :: flag_aerosol
    … …  
    9395    LOGICAL, SAVE       :: ok_LES_omp   
    9496    LOGICAL, SAVE       :: callstats_omp
    95     LOGICAL, SAVE       :: ok_ade_omp, ok_aie_omp, ok_alw_omp, ok_cdnc_omp
     97    LOGICAL, SAVE       :: ok_ade_omp, ok_aie_omp, ok_alw_omp, ok_cdnc_omp, ok_volcan_omp
    9698    LOGICAL, SAVE       :: aerosol_couple_omp, chemistry_couple_omp
    9799    INTEGER, SAVE       :: flag_aerosol_omp
    … …  
    151153
    152154    REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp
    153     REAL      :: solaire_omp_init
     155    REAL,SAVE      :: solaire_omp_init
    154156    LOGICAL,SAVE :: ok_suntime_rrtm_omp
    155157    REAL,SAVE :: co2_ppm_omp, RCO2_omp, co2_ppm_per_omp, RCO2_per_omp
    … …  
    231233    LOGICAL, SAVE :: carbon_cycle_tr_omp
    232234    LOGICAL, SAVE :: carbon_cycle_cpl_omp
     235    LOGICAL, SAVE :: carbon_cycle_rad_omp
    233236    INTEGER, SAVE :: level_coupling_esm_omp
    234237    LOGICAL, SAVE :: adjust_tropopause_omp
    … …  
    395398    ok_cdnc_omp = .FALSE.
    396399    CALL getin('ok_cdnc', ok_cdnc_omp)
     400
     401    !
     402    !Config Key  = ok_volcan
     403    !Config Desc = ok to generate volcanic diags
     404    !Config Def  = .FALSE.
     405    !Config Help = Used in radlwsw_m.F
     406    !
     407    ok_volcan_omp = .FALSE.
     408    CALL getin('ok_volcan', ok_volcan_omp)
     409
    397410    !
    398411    !Config Key  = aerosol_couple
    … …  
    595608    ! RCO2 = 5.286789092164308E-04
    596609    !ancienne valeur
    597     RCO2_omp = co2_ppm_omp * 1.0e-06  * 44.011/28.97 ! pour co2_ppm=348.
     610    RCO2_omp = co2_ppm_omp * 1.0e-06 * RMCO2 / RMD ! pour co2_ppm=348.
    598611
    599612    !  CALL getin('RCO2', RCO2)
    … …  
    615628    CALL getin('CH4_ppb', zzz)
    616629    CH4_ppb_omp = zzz
    617     RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97
     630    RCH4_omp = CH4_ppb_omp * 1.0E-09 * RMCH4 / RMD
    618631    !
    619632    !Config Key  = RN2O
    … …  
    633646    CALL getin('N2O_ppb', zzz)
    634647    N2O_ppb_omp = zzz
    635     RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97
     648    RN2O_omp = N2O_ppb_omp * 1.0E-09 * RMN2O / RMD
    636649    !
    637650    !Config Key  = RCFC11
    … …  
    645658    CALL getin('CFC11_ppt',zzz)
    646659    CFC11_ppt_omp = zzz
    647     RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97
     660    RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * RMCFC11 / RMD
    648661    ! RCFC11 = 1.327690990680013E-09
    649662    !OK CALL getin('RCFC11', RCFC11)
    … …  
    659672    CALL getin('CFC12_ppt',zzz)
    660673    CFC12_ppt_omp = zzz
    661     RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97
     674    RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * RMCFC12 / RMD
    662675    ! RCFC12 = 2.020102726958923E-09
    663676    !OK CALL getin('RCFC12', RCFC12)
    … …  
    679692    !Config Help =
    680693    !               
    681     RCO2_per_omp = co2_ppm_per_omp * 1.0e-06  * 44.011/28.97
     694    RCO2_per_omp = co2_ppm_per_omp * 1.0e-06 * RMCO2 / RMD
    682695
    683696    !Config Key  = ok_4xCO2atm
    … …  
    694707    CALL getin('CH4_ppb_per', zzz)
    695708    CH4_ppb_per_omp = zzz
    696     RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * 16.043/28.97
     709    RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * RMCH4 / RMD
    697710    !
    698711    !Config Key  = RN2O_per
    … …  
    704717    CALL getin('N2O_ppb_per', zzz)
    705718    N2O_ppb_per_omp = zzz
    706     RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * 44.013/28.97
     719    RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * RMN2O / RMD
    707720    !
    708721    !Config Key  = RCFC11_per
    … …  
    714727    CALL getin('CFC11_ppt_per',zzz)
    715728    CFC11_ppt_per_omp = zzz
    716     RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * 137.3686/28.97
     729    RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * RMCFC11 / RMD
    717730    !
    718731    !Config Key  = RCFC12_per
    … …  
    724737    CALL getin('CFC12_ppt_per',zzz)
    725738    CFC12_ppt_per_omp = zzz
    726     RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * 120.9140/28.97
     739    RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * RMCFC12 / RMD
    727740    !ajout CFMIP end
    728741
    … …  
    10311044    ! - 1 = stratospheric aerosols scaled from 550 nm AOD
    10321045    ! - 2 = stratospheric aerosol properties from CMIP6
    1033     !Option 2 is only available with RRTM, this is tested later on
     1046    !Option 2 is only available with RRTM, this is tested later on 
    10341047    !Config Def  = 0
    10351048    !Config Help = Used in physiq.F
    … …  
    17241737    !Config Desc = freq_calNMC(2) = frequence de calcul fichiers histdayNMC
    17251738    !Config Desc = freq_calNMC(3) = frequence de calcul fichiers histhfNMC
    1726     !Config Def  = pasphys
    1727     !Config Help =
    1728     !
    1729     freq_calNMC_omp(1) = pasphys
    1730     freq_calNMC_omp(2) = pasphys
    1731     freq_calNMC_omp(3) = pasphys
     1739    !Config Def  = phys_tstep
     1740    !Config Help =
     1741    !
     1742    freq_calNMC_omp(1) = phys_tstep
     1743    freq_calNMC_omp(2) = phys_tstep
     1744    freq_calNMC_omp(3) = phys_tstep
    17321745    CALL getin('freq_calNMC',freq_calNMC_omp)
    17331746    !
    … …  
    21562169    carbon_cycle_cpl_omp=.FALSE.
    21572170    CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp)
     2171
     2172    carbon_cycle_rad_omp=.FALSE.
     2173    CALL getin('carbon_cycle_rad',carbon_cycle_rad_omp)
    21582174
    21592175    ! >> PC
    … …  
    23062322    ok_alw = ok_alw_omp
    23072323    ok_cdnc = ok_cdnc_omp
     2324    ok_volcan = ok_volcan_omp
    23082325    aerosol_couple = aerosol_couple_omp
    23092326    chemistry_couple = chemistry_couple_omp
    … …  
    24282445    carbon_cycle_tr = carbon_cycle_tr_omp
    24292446    carbon_cycle_cpl = carbon_cycle_cpl_omp
     2447    carbon_cycle_rad = carbon_cycle_rad_omp
    24302448    level_coupling_esm = level_coupling_esm_omp
    24312449
    … …  
    25292547    IF (flag_bc_internal_mixture .AND. flag_aerosol.NE.6) THEN
    25302548       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with flag_aerosol=6',1)
     2549    ENDIF
     2550
     2551    ! Test on carbon cycle
     2552    IF (carbon_cycle_tr .AND. .NOT. carbon_cycle_cpl) THEN
     2553       CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_tr is on',1)
     2554    ENDIF
     2555    IF (carbon_cycle_rad .AND. .NOT. carbon_cycle_cpl) THEN
     2556       CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_rad is on',1)
    25312557    ENDIF
    25322558
    … …  
    26432669    WRITE(lunout,*) ' pmagic = ',pmagic
    26442670    WRITE(lunout,*) ' ok_ade = ',ok_ade
     2671    WRITE(lunout,*) ' ok_volcan = ',ok_volcan
    26452672    WRITE(lunout,*) ' ok_aie = ',ok_aie
    26462673    WRITE(lunout,*) ' ok_alw = ',ok_alw
    … …  
    27422769    WRITE(lunout,*) ' carbon_cycle_tr = ', carbon_cycle_tr
    27432770    WRITE(lunout,*) ' carbon_cycle_cpl = ', carbon_cycle_cpl
     2771    WRITE(lunout,*) ' carbon_cycle_rad = ', carbon_cycle_rad
    27442772    WRITE(lunout,*) ' level_coupling_esm = ', level_coupling_esm
    27452773

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cosp/phys_cosp.F90

    r3403 r3605  
    354354      !$OMP END MASTER
    355355      !$OMP BARRIER
    356         debut_cosp=.false.
    357356      endif ! debut_cosp
    358357!    else
    … …  
    366365!        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
    367366!#else
    368        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     367     if (.NOT. debut_cosp) call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
    369368!#endif
    370369!!
    … …  
    374373
    375374!       print *, 'Calling write output'
    376        call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_val, &
     375     if (.NOT. debut_cosp) call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_val, &
    377376                               cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, &
    378377                               isccp, misr, modis)
    … …  
    400399!  call system_clock(t1,count_rate,count_max)
    401400!  print *,(t1-t0)*1.0/count_rate
     401    if (debut_cosp) then
     402      debut_cosp=.false.
     403    endif
    402404 
    403405  CONTAINS

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cosp2/cosp_output_mod.F90

    r3369 r3605  
    359359   WRITE(lunout,*) 'wxios_add_vaxis cth16 numMISRHgtBins, misr_histHgtCenters ', &
    360360                    numMISRHgtBins, misr_histHgtCenters
    361    CALL wxios_add_vaxis("cth", numMISRHgtBins, misr_histHgtCenters)
     361   CALL wxios_add_vaxis("cth16", numMISRHgtBins, misr_histHgtCenters)
    362362
    363363   WRITE(lunout,*) 'wxios_add_vaxis dbze DBZE_BINS, dbze_ax ', &

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cpl_mod.F90

    r3102 r3605  
    9797  !$OMP THREADPRIVATE(cpl_atm_co22D)
    9898
     99!!!!!!!!!! variable for calving
     100  INTEGER, PARAMETER :: nb_zone_calving = 3
     101  REAL,ALLOCATABLE, DIMENSION(:,:,:),SAVE :: area_calving
     102  !$OMP THREADPRIVATE(area_calving)
     103  REAL,ALLOCATABLE, DIMENSION(:,:),SAVE :: cell_area2D
     104  !$OMP THREADPRIVATE(cell_area2D)
     105  INTEGER, SAVE :: ind_calving(nb_zone_calving)
     106  !$OMP THREADPRIVATE(ind_calving)
     107
     108  LOGICAL,SAVE :: cpl_old_calving
     109  !$OMP THREADPRIVATE(cpl_old_calving)
     110 
    99111CONTAINS
    100112!
    … …  
    105117    USE surface_data
    106118    USE indice_sol_mod
    107     USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
     119    USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid1dTo2d_glo, klon_glo, grid_type, unstructured, regular_lonlat
    108120    USE time_phylmdz_mod, ONLY: annee_ref, day_ini, itau_phy, itaufin_phy
    109121    USE print_control_mod, ONLY: lunout
     122    USE geometry_mod, ONLY : longitude_deg, latitude_deg, ind_cell_glo, cell_area
     123    USE ioipsl_getin_p_mod, ONLY: getin_p
    110124
    111125! Input arguments
    … …  
    127141    CHARACTER(len = 80)               :: abort_message
    128142    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
     143    REAL, DIMENSION(klon_mpi)         :: rlon_mpi, rlat_mpi, cell_area_mpi
     144    INTEGER, DIMENSION(klon_mpi)           :: ind_cell_glo_mpi
     145    REAL, DIMENSION(nbp_lon,jj_nb)         :: lon2D, lat2D
     146    INTEGER :: mask_calving(nbp_lon,jj_nb,nb_zone_calving)
     147    REAL :: pos
     148
     149!***************************************
     150! Use old calving or not (default new calving method)
     151! New calving method should be used with DYNAMICO and when using new coupling
     152! weights.
     153    cpl_old_calving=.FALSE.
     154    CALL getin_p("cpl_old_calving",cpl_old_calving)
     155
    129156
    130157!*************************************************************************************
    … …  
    204231
    205232! Allocate variable in carbon_cycle_mod
    206        ALLOCATE(fco2_ocn_day(klon), stat = error)
     233       IF (.NOT.ALLOCATED(fco2_ocn_day)) ALLOCATE(fco2_ocn_day(klon), stat = error)
    207234       sum_error = sum_error + error
    208     END IF
    209 
     235    ENDIF
     236
     237! calving initialization
     238    ALLOCATE(area_calving(nbp_lon, jj_nb, nb_zone_calving), stat = error)
     239    sum_error = sum_error + error
     240    ALLOCATE(cell_area2D(nbp_lon, jj_nb), stat = error)   
     241    sum_error = sum_error + error
     242
     243
     244    CALL gather_omp(longitude_deg,rlon_mpi)
     245    CALL gather_omp(latitude_deg,rlat_mpi)
     246    CALL gather_omp(ind_cell_glo,ind_cell_glo_mpi)
     247    CALL gather_omp(cell_area,cell_area_mpi)
     248     
     249    IF (is_omp_master) THEN
     250      CALL Grid1DTo2D_mpi(rlon_mpi,lon2D)
     251      CALL Grid1DTo2D_mpi(rlat_mpi,lat2D)
     252      CALL Grid1DTo2D_mpi(cell_area_mpi,cell_area2D)
     253      mask_calving(:,:,:) = 0
     254      WHERE ( lat2D >= 40) mask_calving(:,:,1) = 1
     255      WHERE ( lat2D < 40 .AND. lat2D > -50) mask_calving(:,:,2) = 1
     256      WHERE ( lat2D <= -50) mask_calving(:,:,3) = 1
     257   
     258   
     259      DO i=1,nb_zone_calving
     260        area_calving(:,:,i)=mask_calving(:,:,i)*cell_area2D(:,:)
     261        pos=1
     262        IF (i>1) pos = 1 + ((nbp_lon*nbp_lat-1)*(i-1))/(nb_zone_calving-1)
     263     
     264        ind_calving(i)=0
     265        IF (grid_type==unstructured) THEN
     266
     267          DO ig=1,klon_mpi
     268            IF (ind_cell_glo_mpi(ig)==pos) ind_calving(i)=ig
     269          ENDDO
     270
     271        ELSE IF (grid_type==regular_lonlat) THEN
     272          IF ((ij_begin<=pos .AND. ij_end>=pos) .OR. (ij_begin<=pos .AND. is_south_pole_dyn )) THEN
     273            ind_calving(i)=pos-(jj_begin-1)*nbp_lon
     274          ENDIF
     275        ENDIF
     276     
     277      ENDDO
     278    ENDIF
     279   
     280           
    210281    IF (sum_error /= 0) THEN
    211282       abort_message='Pb allocation variables couplees'
    … …  
    236307       idayref = day_ini
    237308       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
    238        CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon,zx_lon)
     309       CALL grid1dTo2d_glo(rlon,zx_lon)
    239310       DO i = 1, nbp_lon
    240311          zx_lon(i,1) = rlon(i+1)
    241312          zx_lon(i,nbp_lat) = rlon(i+1)
    242313       ENDDO
    243        CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat,zx_lat)
     314       CALL grid1dTo2d_glo(rlat,zx_lat)
    244315       clintocplnam="cpl_atm_tauflx"
    245316       CALL histbeg(clintocplnam,nbp_lon,zx_lon(:,1),nbp_lat,zx_lat(1,:),&
    … …  
    259330                "-",nbp_lon,nbp_lat,nhoridct,1,1,1,-99,32,"inst",dtime,dtime)
    260331         ENDIF
    261        END DO
     332       ENDDO
    262333       CALL histend(nidct)
    263334       CALL histsync(nidct)
    … …  
    272343                "-",nbp_lon,nbp_lat,nhoridcs,1,1,1,-99,32,"inst",dtime,dtime)
    273344         ENDIF
    274        END DO
     345       ENDDO
    275346       CALL histend(nidcs)
    276347       CALL histsync(nidcs)
    … …  
    286357       abort_message='carbon_cycle_cpl does not work with opa8'
    287358       CALL abort_physic(modname,abort_message,1)
    288     END IF
     359    ENDIF
    289360
    290361  END SUBROUTINE cpl_init
    … …  
    356427                CALL histwrite(nidcs,inforecv(i)%name,itau_w,tab_read_flds(:,:,i),nbp_lon*(nbp_lat),ndexcs)
    357428            ENDIF
    358           END DO
     429          ENDDO
    359430       ENDIF
    360431
    … …  
    415486       ENDDO
    416487
    417     END IF ! if time to receive
     488    ENDIF ! if time to receive
    418489
    419490  END SUBROUTINE cpl_receive_frac
    … …  
    466537       DO i=1,klon
    467538          index(i)=i
    468        END DO
     539       ENDDO
    469540       CALL cpl2gath(read_co2, fco2_ocn_day, klon, index)
    470     END IF
     541    ENDIF
    471542
    472543!*************************************************************************************
    … …  
    477548    DO i=1, knon
    478549       tsurf_new(i) = tsurf_new(i)/(1. - sic_new(i))
    479     END DO
     550    ENDDO
    480551
    481552  END SUBROUTINE cpl_receive_ocean_fields
    … …  
    529600       tsurf_new(i) = tsurf_new(i) / sic_new(i)
    530601       alb_new(i)   = alb_new(i)   / sic_new(i)
    531     END DO
     602    ENDDO
    532603
    533604  END SUBROUTINE cpl_receive_seaice_fields
    … …  
    637708          cpl_atm_co2(ig,cpl_index) = cpl_atm_co2(ig,cpl_index) + &
    638709               co2_send(knindex(ig))/ REAL(nexca)
    639        END IF
     710!!---OB: this is correct but why knindex ??
     711       ENDIF
    640712     ENDDO
    641713
    … …  
    682754             ALLOCATE(cpl_atm_co22D(nbp_lon,jj_nb), stat=error)
    683755             sum_error = sum_error + error
    684           END IF
     756          ENDIF
    685757
    686758          IF (sum_error /= 0) THEN
    … …  
    886958             ALLOCATE(cpl_atm_co22D(nbp_lon,jj_nb), stat=error)
    887959             sum_error = sum_error + error
    888           END IF
     960          ENDIF
    889961
    890962          IF (sum_error /= 0) THEN
    … …  
    917989       DO ig = 1, knon
    918990          cpl_fder_tmp(knindex(ig))=cpl_fder(ig,cpl_index)
    919        END DO
     991       ENDDO
    920992       CALL gath2cpl(cpl_fder_tmp(:), cpl_fder2D(:,:,cpl_index), &
    921993            klon, unity)
    … …  
    10851157! Local variables
    10861158!*************************************************************************************
    1087     INTEGER                                              :: error, sum_error, j
     1159    INTEGER                                              :: error, sum_error, i,j,k
    10881160    INTEGER                                              :: itau_w
    10891161    INTEGER                                              :: time_sec
    … …  
    11021174! Table with all fields to send to coupler
    11031175    REAL, DIMENSION(nbp_lon, jj_nb, maxsend)                 :: tab_flds
    1104     REAL, DIMENSION(klon_mpi)                            :: rlon_mpi, rlat_mpi
    1105 
     1176    REAL, DIMENSION(klon_mpi)                                :: rlon_mpi, rlat_mpi
     1177    REAL  :: calving(nb_zone_calving)
     1178    REAL  :: calving_glo(nb_zone_calving)
     1179   
    11061180#ifdef CPP_MPI
    11071181    INCLUDE 'mpif.h'
    … …  
    11301204   
    11311205    IF (version_ocean=='nemo') THEN
    1132        tab_flds(:,:,ids_liqrun) = cpl_rriv2D(:,:) + cpl_rcoa2D(:,:)
     1206       tab_flds(:,:,ids_liqrun) = (cpl_rriv2D(:,:) + cpl_rcoa2D(:,:))
    11331207       IF (carbon_cycle_cpl) tab_flds(:,:,ids_atmco2)=cpl_atm_co22D(:,:)
    11341208    ELSE IF (version_ocean=='opa8') THEN
    … …  
    11391213       tab_flds(:,:,ids_runcoa) = cpl_rcoa2D(:,:)
    11401214       tab_flds(:,:,ids_rivflu) = cpl_rriv2D(:,:)
    1141     END IF
     1215    ENDIF
    11421216
    11431217!*************************************************************************************
    … …  
    11581232    IF (is_omp_root) THEN
    11591233
    1160       DO j = 1, jj_nb
    1161          tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:nbp_lon,j), &
    1162               pctsrf2D(1:nbp_lon,j,is_lic)) / REAL(nbp_lon)
    1163       ENDDO
    1164    
    1165    
    1166       IF (is_parallel) THEN
    1167          IF (.NOT. is_north_pole_dyn) THEN
     1234      IF (cpl_old_calving) THEN   ! use old calving
     1235
     1236        DO j = 1, jj_nb
     1237           tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:nbp_lon,j), &
     1238                pctsrf2D(1:nbp_lon,j,is_lic)) / REAL(nbp_lon)
     1239        ENDDO
     1240   
     1241   
     1242        IF (is_parallel) THEN
     1243           IF (.NOT. is_north_pole_dyn) THEN
    11681244#ifdef CPP_MPI
    1169             CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
    1170             CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
     1245              CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
     1246              CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
    11711247#endif
    1172          ENDIF
     1248           ENDIF
    11731249       
    1174          IF (.NOT. is_south_pole_dyn) THEN
     1250           IF (.NOT. is_south_pole_dyn) THEN
    11751251#ifdef CPP_MPI
    1176             CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
    1177             CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
     1252              CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
     1253              CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
    11781254#endif
    1179          ENDIF
     1255           ENDIF
    11801256         
    1181          IF (.NOT. is_north_pole_dyn .AND. ii_begin /=1) THEN
    1182             Up=Up+tmp_calv(nbp_lon,1)
    1183             tmp_calv(:,1)=Up
    1184          ENDIF
     1257           IF (.NOT. is_north_pole_dyn .AND. ii_begin /=1) THEN
     1258              Up=Up+tmp_calv(nbp_lon,1)
     1259              tmp_calv(:,1)=Up
     1260           ENDIF
     1261           
     1262           IF (.NOT. is_south_pole_dyn .AND. ii_end /= nbp_lon) THEN
     1263              Down=Down+tmp_calv(1,jj_nb)
     1264              tmp_calv(:,jj_nb)=Down
     1265           ENDIF
     1266        ENDIF
     1267        tab_flds(:,:,ids_calvin) = tmp_calv(:,:)
     1268
     1269      ELSE
     1270         ! cpl_old_calving=FALSE
     1271         ! To be used with new method for calculation of coupling weights
     1272         DO k=1,nb_zone_calving
     1273            calving(k)=0
     1274            DO j = 1, jj_nb
     1275               calving(k)= calving(k)+DOT_PRODUCT(cpl_rlic2D(:,j)*area_calving(:,j,k),pctsrf2D(:,j,is_lic))
     1276            ENDDO
     1277         ENDDO
    11851278         
    1186          IF (.NOT. is_south_pole_dyn .AND. ii_end /= nbp_lon) THEN
    1187             Down=Down+tmp_calv(1,jj_nb)
    1188             tmp_calv(:,jj_nb)=Down       
    1189          ENDIF
     1279#ifdef CPP_MPI
     1280         CALL MPI_ALLREDUCE(calving, calving_glo, nb_zone_calving, MPI_REAL_LMDZ, MPI_SUM, COMM_LMDZ_PHY, error)
     1281#endif
     1282         
     1283         tab_flds(:,:,ids_calvin) = 0
     1284         DO k=1,nb_zone_calving
     1285            IF (ind_calving(k)>0 ) THEN
     1286               j=(ind_calving(k)-1)/nbp_lon + 1
     1287               i=MOD(ind_calving(k)-1,nbp_lon)+1
     1288               tab_flds(i,j,ids_calvin) = calving_glo(k)
     1289            ENDIF
     1290         ENDDO
     1291         
    11901292      ENDIF
    11911293     
    1192       tab_flds(:,:,ids_calvin) = tmp_calv(:,:)
    1193 
    11941294!*************************************************************************************
    11951295! Calculate total flux for snow, rain and wind with weighted addition using the
    … …  
    12521352                  cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
    12531353          ENDWHERE
    1254        END IF
     1354       ENDIF
    12551355
    12561356    ENDIF ! is_omp_root
    … …  
    13361436       DEALLOCATE(cpl_atm_co22D, stat=error )
    13371437       sum_error = sum_error + error
    1338     END IF
     1438    ENDIF
    13391439
    13401440    IF (sum_error /= 0) THEN

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv30_routines.F90

    r2520 r3605  
    30503050  ! variables pour tracer dans precip de l'AA et des mel
    30513051  ! local variables:
    3052   INTEGER i, j, k
     3052  INTEGER i, j, k, nam1
    30533053  REAL epm(nloc, na, na)
    30543054
     3055  nam1=na-1 ! Introduced because ep is not defined for j=na
    30553056  ! variables d'Emanuel : du second indice au troisieme
    30563057  ! --->    tab(i,k,j) -> de l origine k a l arrivee j
    … …  
    30823083  ! fraction deau condensee dans les melanges convertie en precip : epm
    30833084  ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
    3084   DO j = 1, na
     3085  DO j = 1, nam1
    30853086    DO k = 1, j - 1
    30863087      DO i = 1, ncum
    … …  
    30953096  END DO
    30963097
    3097   DO j = 1, na
    3098     DO k = 1, na
     3098  DO j = 1, nam1
     3099    DO k = 1, nam1
    30993100      DO i = 1, ncum
    31003101        IF (k>=icb(i) .AND. k<=inb(i)) THEN
    … …  
    31063107  END DO
    31073108
    3108   DO j = 1, na
     3109  DO j = 1, nam1
    31093110    DO k = 1, j - 1
    31103111      DO i = 1, ncum
    … …  
    31173118
    31183119  ! matrices pour calculer la tendance des concentrations dans cvltr.F90
    3119   DO j = 1, na
    3120     DO k = 1, na
     3120  DO j = 1, nam1
     3121    DO k = 1, nam1
    31213122      DO i = 1, ncum
    31223123        da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j)
    … …  
    31273128  END DO
    31283129
    3129   DO j = 1, na
     3130  DO j = 1, nam1
    31303131    DO k = 1, j - 1
    31313132      DO i = 1, ncum
    … …  
    32983299      integer i,k   
    32993300      real hp_bak(nloc,nd)
     3301      CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
     3302      CHARACTER (LEN=80) :: abort_message
    33003303
    33013304        ! on recalcule ep et hp
    … …  
    33463349           write(*,*) 'clw(i,k)=',clw(i,k)
    33473350           write(*,*) 'cpd,cpv=',cpd,cpv
    3348            stop
     3351           CALL abort_physic(modname,abort_message,0)
    33493352        endif
    33503353       enddo !do k=1,nl

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3_mixscale.F90

    r1992 r3605  
    1313  include "cv3param.h"
    1414
    15   INTEGER nloc, ncum, na
     15!inputs:
     16  INTEGER, INTENT (IN)                               :: ncum, na, nloc
     17  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m
     18!input/outputs:
     19  REAL, DIMENSION (nloc, na, na), INTENT (INOUT)     :: ment
     20
     21!local variables:
    1622  INTEGER i, j, il
    17   REAL ment(nloc, na, na), m(nloc, na)
    1823
    19   DO j = 1, nl
    20     DO i = 1, nl
    21       DO il = 1, ncum
    22         ment(il, i, j) = m(il, i)*ment(il, i, j)
     24    DO j = 1, nl
     25      DO i = 1, nl
     26        DO il = 1, ncum
     27          ment(il, i, j) = m(il, i)*ment(il, i, j)
     28        END DO
    2329      END DO
    2430    END DO
    25   END DO
    2631
    2732

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3_routines.F90

    r3345 r3605  
    3535
    3636  include "cv3param.h"
     37  include "cvflag.h"
    3738  include "conema3.h"
    3839
    … …  
    125126     tlcrit=-55.0
    126127     CALL getin_p('tlcrit',tlcrit)
     128     ejectliq=0.
     129     CALL getin_p('ejectliq',ejectliq)
     130     ejectice=0.
     131     CALL getin_p('ejectice',ejectice)
     132     cvflag_prec_eject = .FALSE.
     133     CALL getin_p('cvflag_prec_eject',cvflag_prec_eject)
     134     qsat_depends_on_qt = .FALSE.
     135     CALL getin_p('qsat_depends_on_qt',qsat_depends_on_qt)
     136     adiab_ascent_mass_flux_depends_on_ejectliq = .FALSE.
     137     CALL getin_p('adiab_ascent_mass_flux_depends_on_ejectliq',adiab_ascent_mass_flux_depends_on_ejectliq)
     138     keepbug_ice_frac = .TRUE.
     139     CALL getin_p('keepbug_ice_frac', keepbug_ice_frac)
    127140
    128141    WRITE (*, *) 't_top_max=', t_top_max
    … …  
    144157    WRITE (*, *) 'elcrit=', elcrit
    145158    WRITE (*, *) 'tlcrit=', tlcrit
     159    WRITE (*, *) 'ejectliq=', ejectliq
     160    WRITE (*, *) 'ejectice=', ejectice
     161    WRITE (*, *) 'cvflag_prec_eject =', cvflag_prec_eject
     162    WRITE (*, *) 'qsat_depends_on_qt =', qsat_depends_on_qt
     163    WRITE (*, *) 'adiab_ascent_mass_flux_depends_on_ejectliq =', adiab_ascent_mass_flux_depends_on_ejectliq
     164    WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac
     165
    146166    first = .FALSE.
    147167  END IF ! (first)
    … …  
    170190
    171191  include "cv3param.h"
     192  include "cvflag.h"
    172193
    173194!inputs:
    … …  
    236257! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
    237258      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
    238       lf(i, k) = lf0 - clmci*(t(i,k)-273.15)
     259!!      lf(i, k) = lf0 - clmci*(t(i,k)-273.15)   ! erreur de signe !!
     260      lf(i, k) = lf0 + clmci*(t(i,k)-273.15)
    239261      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
    240262      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
    … …  
    289311  USE mod_phys_lmdz_transfert_para, ONLY : bcast
    290312  USE add_phys_tend_mod, ONLY: fl_cor_ebil
     313  USE print_control_mod, ONLY: prt_level
    291314  IMPLICIT NONE
    292315
    … …  
    516539    END DO
    517540  ENDIF
     541  IF (prt_level .GE. 10) THEN
     542    print *,'cv3_feed : iflag(1), pfeed(1), plcl(1), wghti(1,k) ', &
     543                        iflag(1), pfeed(1), plcl(1), (wghti(1,k),k=1,10)
     544  ENDIF
    518545
    519546! -------------------------------------------------------------------
    … …  
    11051132                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
    11061133                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
    1107                          inb, tp, tvp, clw, hp, ep, sigp, buoy, frac)
     1134                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
     1135                         frac_a, frac_s, qpreca, qta)
    11081136  USE print_control_mod, ONLY: prt_level
    11091137  IMPLICIT NONE
    … …  
    11531181  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ep, sigp, hp
    11541182  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: buoy
    1155   REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: frac
     1183  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: frac_a, frac_s
     1184  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qpreca
     1185  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qta
    11561186
    11571187!local variables:
    11581188  INTEGER i, j, k
    1159   REAL tg, qg, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
     1189  REAL smallestreal
     1190  REAL tg, qg, dqgdT, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
     1191  REAL                                               :: phinu2p
    11601192  REAL als
    1161   REAL qsat_new, snew, qi(nloc, nd)
    1162   REAL by, defrac, pden, tbis
    1163   REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
    1164   LOGICAL lcape(nloc)
    1165   INTEGER iposit(nloc)
    1166   REAL fracg
    1167   REAL deltap
     1193  REAL                                               :: qsat_new, snew
     1194  REAL, DIMENSION (nloc,nd)                          :: qi
     1195  REAL, DIMENSION (nloc,nd)                          :: ha    ! moist static energy of adiabatic ascents
     1196                                                              ! taking into account precip ejection
     1197  REAL, DIMENSION (nloc,nd)                          :: hla   ! liquid water static energy of adiabatic ascents
     1198                                                              ! taking into account precip ejection
     1199  REAL, DIMENSION (nloc,nd)                          :: qcld  ! specific cloud water
     1200  REAL, DIMENSION (nloc,nd)                          :: qhsat    ! specific humidity at saturation
     1201  REAL, DIMENSION (nloc,nd)                          :: dqhsatdT ! dqhsat/dT
     1202  REAL, DIMENSION (nloc,nd)                          :: frac  ! ice fraction function of envt temperature
     1203  REAL, DIMENSION (nloc,nd)                          :: qps   ! specific solid precipitation
     1204  REAL, DIMENSION (nloc,nd)                          :: qpl   ! specific liquid precipitation
     1205  REAL, DIMENSION (nloc)                             :: ah0, cape, capem, byp
     1206  LOGICAL, DIMENSION (nloc)                          :: lcape
     1207  INTEGER, DIMENSION (nloc)                          :: iposit
     1208  REAL                                               :: denomm1
     1209  REAL                                               :: by, defrac, pden, tbis
     1210  REAL                                               :: fracg
     1211  REAL                                               :: deltap
     1212  REAL, SAVE                                         :: Tx, Tm
     1213  DATA Tx/263.15/, Tm/243.15/
     1214!$OMP THREADPRIVATE(Tx, Tm)
     1215  REAL                                               :: aa, bb, dd, ddelta, discr
     1216  REAL                                               :: ff, fp
     1217  REAL                                               :: coefx, coefm, Zx, Zm, Ux, U, Um
    11681218
    11691219  IF (prt_level >= 10) THEN
    1170     print *,'cv3_undilute2.0. t(1,k), q(1,k), qs(1,k) ', &
    1171                         (k, t(1,k), q(1,k), qs(1,k), k = 1,nl)
     1220    print *,'cv3_undilute2.0. icvflag_Tpa, t(1,k), q(1,k), qs(1,k) ', &
     1221                        icvflag_Tpa, (k, t(1,k), q(1,k), qs(1,k), k = 1,nl)
    11721222  ENDIF
     1223  smallestreal=tiny(smallestreal)
    11731224
    11741225! =====================================================================
    … …  
    11811232    END DO
    11821233  END DO
     1234
    11831235
    11841236! =====================================================================
    … …  
    11971249             qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
    11981250  END DO
    1199 
     1251!
     1252!  Ice fraction
     1253!
     1254  IF (cvflag_ice) THEN
     1255    DO k = minorig, nl
     1256      DO i = 1, ncum
     1257          frac(i, k) = (Tx - t(i,k))/(Tx - Tm)
     1258          frac(i, k) = min(max(frac(i,k),0.0), 1.0)
     1259      END DO
     1260    END DO
     1261! Below cloud base, set ice fraction to cloud base value
     1262    DO k = 1, nl
     1263      DO i = 1, ncum
     1264        IF (k<icb(i)) THEN
     1265          frac(i,k) = frac(i,icb(i))
     1266        END IF
     1267      END DO
     1268    END DO
     1269  ELSE
     1270    DO k = 1, nl
     1271      DO i = 1, ncum
     1272          frac(i,k) = 0.
     1273      END DO
     1274    END DO
     1275  ENDIF ! (cvflag_ice)
     1276
     1277
     1278  DO k = minorig, nl
     1279    DO i = 1,ncum
     1280      ha(i,k) = ah0(i)
     1281      hla(i,k) = hnk(i)
     1282      qta(i,k) = qnk(i)
     1283      qpreca(i,k) = 0.
     1284      frac_a(i,k) = 0.
     1285      frac_s(i,k) = frac(i,k)
     1286      qpl(i,k) = 0.
     1287      qps(i,k) = 0.
     1288      qhsat(i,k) = qs(i,k)
     1289      qcld(i,k) = max(qta(i,k)-qhsat(i,k),0.)
     1290      IF (k <= icb(i)+1) THEN
     1291        qhsat(i,k) = qnk(i)-clw(i,k)
     1292        qcld(i,k) = clw(i,k)
     1293      ENDIF
     1294    ENDDO
     1295  ENDDO
     1296
     1297!jyg<
     1298! =====================================================================
     1299! --- SET THE THE FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
     1300! =====================================================================
     1301  DO k = 1, nl
     1302    DO i = 1, ncum
     1303      ep(i, k) = 0.0
     1304      sigp(i, k) = spfac
     1305    END DO
     1306  END DO
     1307!>jyg
     1308!
    12001309
    12011310! ***  Find lifted parcel quantities above cloud base    ***
    12021311
    1203 
     1312!----------------------------------------------------------------------------
     1313!
     1314  IF (icvflag_Tpa == 2) THEN
     1315!
     1316!----------------------------------------------------------------------------
     1317!
     1318    DO k = minorig + 1, nl
     1319      DO i = 1,ncum
     1320        tp(i,k) = t(i,k)
     1321      ENDDO
     1322!!      alv = lv0 - clmcpv*(t(i,k)-273.15)
     1323!!      alf = lf0 + clmci*(t(i,k)-273.15)
     1324!!      als = alf + alv
     1325      DO j = 1,4
     1326        DO i = 1, ncum
     1327! ori       if(k.ge.(icb(i)+1))then
     1328          IF (k>=(icbs(i)+1)) THEN                                ! convect3
     1329            tg = tp(i, k)
     1330            IF (tg .gt. Tx) THEN
     1331              es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
     1332              qg = eps*es/(p(i,k)-es*(1.-eps))
     1333            ELSE
     1334              esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
     1335              qg = eps*esi/(p(i,k)-esi*(1.-eps))
     1336            ENDIF
     1337! Ice fraction
     1338            ff = 0.
     1339            fp = 1./(Tx - Tm)
     1340            IF (tg < Tx) THEN
     1341              IF (tg > Tm) THEN
     1342                ff = (Tx - tg)*fp
     1343              ELSE
     1344                ff = 1.
     1345              ENDIF ! (tg > Tm)
     1346            ENDIF ! (tg < Tx)
     1347! Intermediate variables
     1348            aa = cpd + (cl-cpd)*qnk(i) + lv(i,k)*lv(i,k)*qg/(rrv*tg*tg)
     1349            ahg = (cpd + (cl-cpd)*qnk(i))*tg + lv(i,k)*qg - &
     1350                  lf(i,k)*ff*(qnk(i) - qg) + gz(i,k)
     1351            dd = lf(i,k)*lv(i,k)*qg/(rrv*tg*tg)
     1352            ddelta = lf(i,k)*(qnk(i) - qg)
     1353            bb = aa + ddelta*fp + dd*fp*(Tx-tg)
     1354! Compute Zx and Zm
     1355            coefx = aa
     1356            coefm = aa + dd
     1357            IF (tg .gt. Tx) THEN
     1358              Zx = ahg            + coefx*(Tx - tg)
     1359              Zm = ahg - ddelta   + coefm*(Tm - tg)
     1360            ELSE
     1361              IF (tg .gt. Tm) THEN
     1362                Zx = ahg          + (coefx +fp*ddelta)*(Tx - Tg)
     1363                Zm = ahg          + (coefm +fp*ddelta)*(Tm - Tg)
     1364              ELSE
     1365                Zx = ahg + ddelta + coefx*(Tx - tg)
     1366                Zm = ahg          + coefm*(Tm - tg)
     1367              ENDIF ! (tg .gt. Tm)
     1368            ENDIF ! (tg .gt. Tx)
     1369! Compute the masks Um, U, Ux
     1370            Um = (sign(1., Zm-ah0(i))+1.)/2.
     1371            Ux = (sign(1., ah0(i)-Zx)+1.)/2.
     1372            U = (1. - Um)*(1. - Ux)
     1373! Compute the updated parcell temperature Tp : 3 cases depending on tg value
     1374            IF (tg .gt. Tx) THEN
     1375              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tx-tg))
     1376              Tp(i,k) = tg + &
     1377                  Um*  (ah0(i) - ahg + ddelta)           /(aa + dd) + &
     1378                  U *2*(ah0(i) - ahg + ddelta*fp*(Tx-tg))/(bb + sqrt(discr)) + &
     1379                  Ux*  (ah0(i) - ahg)                    /aa
     1380            ELSEIF (tg .gt. Tm) THEN
     1381              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg)
     1382              Tp(i,k) = tg + &
     1383                  Um*  (ah0(i) - ahg + ddelta*fp*(tg-Tm))/(aa + dd) + &
     1384                  U *2*(ah0(i) - ahg)                    /(bb + sqrt(discr)) + &
     1385                  Ux*  (ah0(i) - ahg + ddelta*fp*(tg-Tx))/aa
     1386            ELSE
     1387              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tm-tg))
     1388              Tp(i,k) = tg + &
     1389                  Um*  (ah0(i) - ahg)                    /(aa + dd) + &
     1390                  U *2*(ah0(i) - ahg + ddelta*fp*(Tm-tg))/(bb + sqrt(discr)) + &
     1391                  Ux*  (ah0(i) - ahg - ddelta)           /aa
     1392            ENDIF ! (tg .gt. Tx)
     1393!
     1394!!     print *,' j, k, Um, U, Ux, aa, bb, discr, dd, ddelta ', j, k, Um, U, Ux, aa, bb, discr, dd, ddelta
     1395!!     print *,' j, k, ah0(i), ahg, tg, qg, tp(i,k), ff ', j, k, ah0(i), ahg, tg, qg, tp(i,k), ff
     1396          END IF ! (k>=(icbs(i)+1))
     1397        END DO ! i = 1, ncum
     1398      END DO ! j = 1,4
     1399      DO i = 1, ncum
     1400        IF (k>=(icbs(i)+1)) THEN                                ! convect3
     1401          tg = tp(i, k)
     1402          IF (tg .gt. Tx) THEN
     1403            es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
     1404            qg = eps*es/(p(i,k)-es*(1.-eps))
     1405          ELSE
     1406            esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
     1407            qg = eps*esi/(p(i,k)-esi*(1.-eps))
     1408          ENDIF
     1409          clw(i, k) = qnk(i) - qg
     1410          clw(i, k) = max(0.0, clw(i,k))
     1411          tvp(i, k) = max(0., tp(i,k)*(1.+qg/eps-qnk(i)))
     1412! print*,tvp(i,k),'tvp'
     1413          IF (clw(i,k)<1.E-11) THEN
     1414            tp(i, k) = tv(i, k)
     1415            tvp(i, k) = tv(i, k)
     1416          END IF ! (clw(i,k)<1.E-11)
     1417        END IF ! (k>=(icbs(i)+1))
     1418      END DO ! i = 1, ncum
     1419    END DO ! k = minorig + 1, nl
     1420!----------------------------------------------------------------------------
     1421!
     1422  ELSE IF (icvflag_Tpa == 1) THEN  ! (icvflag_Tpa == 2)
     1423!
     1424!----------------------------------------------------------------------------
     1425!
     1426    DO k = minorig + 1, nl
     1427      DO i = 1,ncum
     1428        tp(i,k) = t(i,k)
     1429      ENDDO
     1430!!      alv = lv0 - clmcpv*(t(i,k)-273.15)
     1431!!      alf = lf0 + clmci*(t(i,k)-273.15)
     1432!!      als = alf + alv
     1433      DO j = 1,4
     1434        DO i = 1, ncum
     1435! ori       if(k.ge.(icb(i)+1))then
     1436          IF (k>=(icbs(i)+1)) THEN                                ! convect3
     1437            tg = tp(i, k)
     1438            IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN
     1439              es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
     1440              qg = eps*es/(p(i,k)-es*(1.-eps))
     1441              dqgdT = lv(i,k)*qg/(rrv*tg*tg)
     1442            ELSE
     1443              esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
     1444              qg = eps*esi/(p(i,k)-esi*(1.-eps))
     1445              dqgdT = (lv(i,k)+lf(i,k))*qg/(rrv*tg*tg)
     1446            ENDIF
     1447            IF (qsat_depends_on_qt) THEN
     1448              dqgdT = dqgdT*(1.-qta(i,k-1))/(1.-qg)**2
     1449              qg = qg*(1.-qta(i,k-1))/(1.-qg)           
     1450            ENDIF
     1451            ahg = (cpd + (cl-cpd)*qta(i,k-1))*tg + lv(i,k)*qg - &
     1452                  lf(i,k)*frac(i,k)*(qta(i,k-1) - qg) + gz(i,k)
     1453            Tp(i,k) = tg + (ah0(i) - ahg)/ &
     1454                    (cpd + (cl-cpd)*qta(i,k-1) + (lv(i,k)+frac(i,k)*lf(i,k))*dqgdT)
     1455!!   print *,'undilute2 iterations k, Tp(i,k), ah0(i), ahg ', &
     1456!!                                 k, Tp(i,k), ah0(i), ahg
     1457          END IF ! (k>=(icbs(i)+1))
     1458        END DO ! i = 1, ncum
     1459      END DO ! j = 1,4
     1460      DO i = 1, ncum
     1461        IF (k>=(icbs(i)+1)) THEN                                ! convect3
     1462          tg = tp(i, k)
     1463          IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN
     1464            es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
     1465            qg = eps*es/(p(i,k)-es*(1.-eps))
     1466          ELSE
     1467            esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
     1468            qg = eps*esi/(p(i,k)-esi*(1.-eps))
     1469          ENDIF
     1470          IF (qsat_depends_on_qt) THEN
     1471            qg = qg*(1.-qta(i,k-1))/(1.-qg)           
     1472          ENDIF
     1473          qhsat(i,k) = qg
     1474        END IF ! (k>=(icbs(i)+1))
     1475      END DO ! i = 1, ncum
     1476      DO i = 1, ncum
     1477        IF (k>=(icbs(i)+1)) THEN                                ! convect3
     1478          clw(i, k) = qta(i,k-1) - qhsat(i,k)
     1479          clw(i, k) = max(0.0, clw(i,k))
     1480          tvp(i, k) = max(0., tp(i,k)*(1.+qhsat(i,k)/eps-qta(i,k-1)))
     1481! print*,tvp(i,k),'tvp'
     1482          IF (clw(i,k)<1.E-11) THEN
     1483            tp(i, k) = tv(i, k)
     1484            tvp(i, k) = tv(i, k)
     1485          END IF ! (clw(i,k)<1.E-11)
     1486        END IF ! (k>=(icbs(i)+1))
     1487      END DO ! i = 1, ncum
     1488!
     1489      IF (cvflag_prec_eject) THEN
     1490        DO i = 1, ncum
     1491          IF (k>=(icbs(i)+1)) THEN                                ! convect3
     1492!  Specific precipitation (liquid and solid) and ice content
     1493!  before ejection of precipitation                                                     !!jygprl
     1494            elacrit = elcrit*min(max(1.-(tp(i,k)-T0)/Tlcrit, 0.), 1.)                   !!jygprl
     1495!!!!            qcld(i,k) = min(clw(i,k), elacrit)                                          !!jygprl
     1496            qcld(i,k) = min(clw(i,k), elacrit*(1.-qta(i,k-1))/(1.-elacrit))             !!jygprl
     1497            phinu2p = qhsat(i,k-1) + qcld(i,k-1) - (qhsat(i,k) + qcld(i,k))                     !!jygprl
     1498            qpl(i,k) = qpl(i,k-1) + (1.-frac(i,k))*phinu2p                            !!jygprl
     1499            qps(i,k) = qps(i,k-1) + frac(i,k)     *phinu2p                            !!jygprl
     1500            qi(i,k) = (1.-ejectliq)*clw(i,k)*frac(i,k) + &                            !!jygprl
     1501                     ejectliq*(qps(i,k-1) + frac(i,k)*(phinu2p+qcld(i,k)))            !!jygprl
     1502!!
     1503!  =====================================================================================
     1504!  Ejection of precipitation from adiabatic ascents if requested (cvflag_prec_eject=True):
     1505!  Compute the steps of total water (qta), of moist static energy (ha), of specific
     1506!  precipitation (qpl and qps) and of specific cloud water (qcld) associated with precipitation
     1507!   ejection.
     1508!  =====================================================================================
     1509! 
     1510!   Verif
     1511            qpreca(i,k) = ejectliq*qpl(i,k) + ejectice*qps(i,k)                                   !!jygprl
     1512            frac_a(i,k) = ejectice*qps(i,k)/max(qpreca(i,k),smallestreal)                         !!jygprl
     1513            frac_s(i,k) = (1.-ejectliq)*frac(i,k) + &                                             !!jygprl
     1514               ejectliq*(1. - (qpl(i,k)+(1.-frac(i,k))*qcld(i,k))/max(clw(i,k),smallestreal))     !!jygprl
     1515!         
     1516            denomm1 = 1./(1. - qpreca(i,k))
     1517!         
     1518            qta(i,k) = qta(i,k-1) - &
     1519                      qpreca(i,k)*(1.-qta(i,k-1))*denomm1
     1520            ha(i,k)  = ha(i,k-1) + &
     1521                      ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cl-cpd)*tp(i,k) + &
     1522                                  lv(i,k)*qhsat(i,k) - lf(i,k)*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + &
     1523                        lf(i,k)*ejectice*qps(i,k))*denomm1
     1524            hla(i,k) = hla(i,k-1) + &
     1525                      ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cpv-cpd)*tp(i,k) - &
     1526                                  lv(i,k)*((1.-frac_s(i,k))*qcld(i,k)+qpl(i,k)) - &
     1527                                  (lv(i,k)+lf(i,k))*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + &
     1528                        lv(i,k)*ejectliq*qpl(i,k) + (lv(i,k)+lf(i,k))*ejectice*qps(i,k))*denomm1
     1529            qpl(i,k) = qpl(i,k)*(1.-ejectliq)*denomm1
     1530            qps(i,k) = qps(i,k)*(1.-ejectice)*denomm1
     1531            qcld(i,k) = qcld(i,k)*denomm1
     1532            qhsat(i,k) = qhsat(i,k)*(1.-qta(i,k))/(1.-qta(i,k-1))
     1533         END IF ! (k>=(icbs(i)+1))
     1534        END DO ! i = 1, ncum
     1535      ENDIF  ! (cvflag_prec_eject)
     1536!
     1537    END DO ! k = minorig + 1, nl
     1538!
     1539!----------------------------------------------------------------------------
     1540!
     1541  ELSE IF (icvflag_Tpa == 0) THEN! (icvflag_Tpa == 2) ELSE IF(icvflag_Tpa == 1)
     1542!
     1543!----------------------------------------------------------------------------
     1544!
    12041545  DO k = minorig + 1, nl
    12051546    DO i = 1, ncum
    … …  
    13581699  END DO
    13591700
    1360   IF (prt_level >= 10) THEN
    1361     print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', &
    1362                           (k, tp(1,k), tvp(1,k), k = 1,nl)
    1363   ENDIF
    1364 
     1701!----------------------------------------------------------------------------
     1702!
     1703  ENDIF ! (icvflag_Tpa == 2) ELSEIF (icvflag_Tpa == 1) ELSE (icvflag_Tpa == 0)
     1704!
     1705!----------------------------------------------------------------------------
     1706!
    13651707! =====================================================================
    1366 ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
    1367 ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
     1708! --- SET THE PRECIPITATION EFFICIENCIES
    13681709! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
    13691710! =====================================================================
    1370 !
    1371 !jyg<
    1372   DO k = 1, nl
    1373     DO i = 1, ncum
    1374       ep(i, k) = 0.0
    1375       sigp(i, k) = spfac
    1376     END DO
    1377   END DO
    1378 !>jyg
    13791711!
    13801712  IF (flag_epkeorig/=1) THEN
    … …  
    14131745    END DO
    14141746  END IF
     1747!
     1748!   =========================================================================
     1749  IF (prt_level >= 10) THEN
     1750    print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', &
     1751                          (k, tp(1,k), tvp(1,k), k = 1,nl)
     1752  ENDIF
    14151753!
    14161754! =====================================================================
    … …  
    16481986  IF (cvflag_ice) THEN
    16491987!
     1988  IF (cvflag_prec_eject) THEN
     1989!!    DO k = minorig + 1, nl
     1990!!      DO i = 1, ncum
     1991!!        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
     1992!!          frac_s(i,k) = qi(i,k)/max(clw(i,k),smallestreal)   
     1993!!          frac_s(i,k) = 1. - (qpl(i,k)+(1.-frac_s(i,k))*qcld(i,k))/max(clw(i,k),smallestreal)   
     1994!!        END IF
     1995!!      END DO
     1996!!    END DO
     1997  ELSE    ! (cvflag_prec_eject)
    16501998    DO k = minorig + 1, nl
    16511999      DO i = 1, ncum
    16522000        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
    1653           frac(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
    1654           frac(i, k) = min(max(frac(i,k),0.0), 1.0)
    1655           hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* &
    1656                               ep(i, k)*clw(i, k)
     2001!jyg< frac computation moved to beginning of cv3_undilute2.
     2002!     kept here for compatibility test with CMip6 version
     2003          frac_s(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
     2004          frac_s(i, k) = min(max(frac_s(i,k),0.0), 1.0)
    16572005        END IF
    16582006      END DO
    16592007    END DO
    1660 ! Below cloud base, set ice fraction to cloud base value
    1661     DO k = 1, nl
     2008  ENDIF  ! (cvflag_prec_eject) ELSE
     2009    DO k = minorig + 1, nl
    16622010      DO i = 1, ncum
    1663         IF (k<icb(i)) THEN
    1664           frac(i,k) = frac(i,icb(i))
     2011        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
     2012!!          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* &     !!jygprl
     2013!!                              ep(i, k)*clw(i, k)                                    !!jygprl
     2014          hp(i, k) = hla(i,k-1) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* &   !!jygprl
     2015                              ep(i, k)*clw(i, k)                                      !!jygprl
    16652016        END IF
    16662017      END DO
    16672018    END DO
    16682019!
    1669   ELSE
     2020  ELSE   ! (cvflag_ice)
    16702021!
    16712022    DO k = minorig + 1, nl
    … …  
    23502701SUBROUTINE cv3_unsat(nloc, ncum, nd, na, ntra, icb, inb, iflag, &
    23512702                     t, rr, rs, gz, u, v, tra, p, ph, &
    2352                      th, tv, lv, lf, cpn, ep, sigp, clw, &
     2703                     th, tv, lv, lf, cpn, ep, sigp, clw, frac_s, qpreca, frac_a, qta , &                       !!jygprl
    23532704                     m, ment, elij, delt, plcl, coef_clos, &
    23542705                     mp, rp, up, vp, trap, wt, water, evap, fondue, ice, &
    23552706                     faci, b, sigd, &
    2356                      wdtrainA, wdtrainM)                                      ! RomP
     2707                     wdtrainA, wdtrainS, wdtrainM)                                      ! RomP
    23572708  USE print_control_mod, ONLY: prt_level, lunout
    23582709  IMPLICIT NONE
    … …  
    23722723  REAL, DIMENSION (nloc, na), INTENT (IN)            :: gz
    23732724  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
    2374   REAL tra(nloc, nd, ntra)
    2375   REAL p(nloc, nd), ph(nloc, nd+1)
    2376   REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, sigp, clw
     2725  REAL, DIMENSION (nloc, nd, ntra), INTENT(IN)       :: tra
     2726  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
     2727  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
     2728  REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, sigp, clw   !adiab ascent shedding
     2729  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac_s          !ice fraction in adiab ascent shedding !!jygprl
     2730  REAL, DIMENSION (nloc, na), INTENT (IN)            :: qpreca          !adiab ascent precip                   !!jygprl
     2731  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac_a          !ice fraction in adiab ascent precip   !!jygprl
     2732  REAL, DIMENSION (nloc, na), INTENT (IN)            :: qta             !adiab ascent specific total water     !!jygprl
    23772733  REAL, DIMENSION (nloc, na), INTENT (IN)            :: th, tv, lv, cpn
    23782734  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
    … …  
    23872743  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: mp, rp, up, vp
    23882744  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: water, evap, wt
    2389   REAL, DIMENSION (nloc, na), INTENT (OUT)           :: ice, fondue, faci
     2745  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: ice, fondue
     2746  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: faci            ! ice fraction in precipitation
    23902747  REAL, DIMENSION (nloc, na, ntra), INTENT (OUT)     :: trap
    23912748  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: b
    … …  
    23952752! Distinction des wdtrain
    23962753! Pa = wdtrainA     Pm = wdtrainM
    2397   REAL, DIMENSION (nloc, na), INTENT (OUT)           :: wdtrainA, wdtrainM
     2754  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: wdtrainA, wdtrainS, wdtrainM
    23982755
    23992756!local variables
    24002757  INTEGER i, j, k, il, num1, ndp1
     2758  REAL smallestreal
    24012759  REAL tinv, delti, coef
    24022760  REAL awat, afac, afac1, afac2, bfac
    … …  
    24052763  REAL ampmax, thaw
    24062764  REAL tevap(nloc)
    2407   REAL lvcp(nloc, na), lfcp(nloc, na)
    2408   REAL h(nloc, na), hm(nloc, na)
    2409   REAL frac(nloc, na)
    2410   REAL fraci(nloc, na), prec(nloc, na)
     2765  REAL, DIMENSION (nloc, na)      :: lvcp, lfcp
     2766  REAL, DIMENSION (nloc, na)      :: h, hm
     2767  REAL, DIMENSION (nloc, na)      :: ma
     2768  REAL, DIMENSION (nloc, na)      :: frac          ! ice fraction in precipitation source
     2769  REAL, DIMENSION (nloc, na)      :: fraci         ! provisionnal ice fraction in precipitation
     2770  REAL, DIMENSION (nloc, na)      :: prec
    24112771  REAL wdtrain(nloc)
    24122772  LOGICAL lwork(nloc), mplus(nloc)
    … …  
    24152775! ------------------------------------------------------
    24162776IF (prt_level .GE. 10) print *,' ->cv3_unsat, iflag(1) ', iflag(1)
     2777
     2778smallestreal=tiny(smallestreal)
    24172779
    24182780! =============================
    … …  
    24342796!! RomP >>>
    24352797wdtrainA(:,:) = 0.
     2798wdtrainS(:,:) = 0.
    24362799wdtrainM(:,:) = 0.
    24372800!! RomP <<<
    … …  
    24892852  END DO
    24902853
     2854!
     2855! Get adiabatic ascent mass flux
     2856!
     2857!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2858  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
     2859!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2860!!! Warning : this option leads to water conservation violation
     2861!!!           Expert only
     2862!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2863    DO il = 1, ncum
     2864      ma(il, nlp) = 0.
     2865      ma(il, 1)   = 0.
     2866    END DO
     2867
     2868  DO i = nl, 2, -1
     2869      DO il = 1, ncum
     2870        ma(il, i) = ma(il, i+1)*(1.-qta(il,i))/(1.-qta(il,i-1)) + m(il, i)
     2871      END DO
     2872  END DO
     2873!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2874  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
     2875!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2876    DO il = 1, ncum
     2877      ma(il, nlp) = 0.
     2878      ma(il, 1)   = 0.
     2879    END DO
     2880
     2881  DO i = nl, 2, -1
     2882      DO il = 1, ncum
     2883        ma(il, i) = ma(il, i+1) + m(il, i)
     2884      END DO
     2885  END DO
     2886
     2887  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
     2888!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    24912889
    24922890! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    … …  
    25132911! ***              calculate detrained precipitation             ***
    25142912
    2515     DO il = 1, ncum
    2516       IF (i<=inb(il) .AND. lwork(il)) THEN
    2517         IF (cvflag_grav) THEN
    2518           wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)
    2519           wdtrainA(il, i) = wdtrain(il)/grav                        !   Pa   RomP
    2520         ELSE
    2521           wdtrain(il) = 10.0*ep(il, i)*m(il, i)*clw(il, i)
    2522           wdtrainA(il, i) = wdtrain(il)/10.                         !   Pa   RomP
    2523         END IF
    2524       END IF
    2525     END DO
     2913
     2914    DO il = 1, ncum                                                   
     2915      IF (i<=inb(il) .AND. lwork(il)) THEN                           
     2916        wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)           
     2917        wdtrainS(il, i) = wdtrain(il)/grav                                            !   Ps   jyg
     2918!!        wdtrainA(il, i) = wdtrain(il)/grav                                          !   Ps   RomP
     2919      END IF                                                         
     2920    END DO                                                           
    25262921
    25272922    IF (i>1) THEN
    … …  
    25312926            awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
    25322927            awat = max(awat, 0.0)
    2533             IF (cvflag_grav) THEN
    2534               wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
    2535               wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i)  !   Pm  RomP
    2536             ELSE
    2537               wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i)
    2538               wdtrainM(il, i) = wdtrain(il)/10. - wdtrainA(il, i)   !   Pm  RomP
    2539             END IF
     2928            wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
     2929            wdtrainM(il, i) = wdtrain(il)/grav - wdtrainS(il, i)    !   Pm  jyg
     2930!!            wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i)  !   Pm  RomP
    25402931          END IF
    25412932        END DO
    … …  
    25432934    END IF
    25442935
     2936    IF (cvflag_prec_eject) THEN
     2937!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2938      IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
     2939!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2940!!! Warning : this option leads to water conservation violation
     2941!!!           Expert only
     2942!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2943          IF ( i > 1) THEN
     2944            DO il = 1, ncum
     2945              IF (i<=inb(il) .AND. lwork(il)) THEN
     2946                wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))/(1. - qta(il, i-1))    !   Pa   jygprl
     2947                wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i)
     2948              END IF
     2949            END DO
     2950          ENDIF  ! ( i > 1)
     2951!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2952      ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
     2953!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2954          IF ( i > 1) THEN
     2955            DO il = 1, ncum
     2956              IF (i<=inb(il) .AND. lwork(il)) THEN
     2957                wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))                        !   Pa   jygprl
     2958                wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i)
     2959              END IF
     2960            END DO
     2961          ENDIF  ! ( i > 1)
     2962
     2963      ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
     2964!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2965    ENDIF  ! (cvflag_prec_eject)
     2966
    25452967
    25462968! ***    find rain water and evaporation using provisional   ***
    … …  
    25482970
    25492971
     2972    IF (cvflag_ice) THEN                                                                                !!jygprl
     2973      IF (cvflag_prec_eject) THEN
     2974        DO il = 1, ncum                                                                                   !!jygprl
     2975          IF (i<=inb(il) .AND. lwork(il)) THEN                                                            !!jygprl
     2976            frac(il, i) = (frac_a(il,i)*wdtrainA(il,i)+frac_s(il,i)*(wdtrainS(il,i)+wdtrainM(il,i))) / &  !!jygprl
     2977                          max(wdtrainA(il,i)+wdtrainS(il,i)+wdtrainM(il,i),smallestreal)                  !!jygprl
     2978            fraci(il, i) = frac(il, i)                                                                    !!jygprl
     2979          END IF                                                                                          !!jygprl
     2980        END DO                                                                                            !!jygprl
     2981      ELSE  ! (cvflag_prec_eject)
     2982        DO il = 1, ncum                                                                                   !!jygprl
     2983          IF (i<=inb(il) .AND. lwork(il)) THEN                                                            !!jygprl
     2984!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2985            IF (keepbug_ice_frac) THEN
     2986              frac(il, i) = frac_s(il, i)
     2987!       Ice fraction computed again here as a function of the temperature seen by unsaturated downdraughts
     2988!       (i.e. the cold pool temperature) for compatibility with earlier versions.
     2989              fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15)
     2990              fraci(il, i) = min(max(fraci(il,i),0.0), 1.0)
     2991!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2992            ELSE  ! (keepbug_ice_frac)
     2993!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2994              frac(il, i) = frac_s(il, i)
     2995              fraci(il, i) = frac(il, i)                                                                    !!jygprl
     2996            ENDIF  ! (keepbug_ice_frac)
     2997!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2998          END IF                                                                                          !!jygprl
     2999        END DO                                                                                            !!jygprl
     3000      ENDIF  ! (cvflag_prec_eject)
     3001    END IF                                                                                              !!jygprl
     3002
     3003
    25503004    DO il = 1, ncum
    25513005      IF (i<=inb(il) .AND. lwork(il)) THEN
    … …  
    25533007        wt(il, i) = 45.0
    25543008
    2555         IF (cvflag_ice) THEN
    2556           frac(il, inb(il)) = 1. - (t(il,inb(il))-243.15)/(263.15-243.15)
    2557           frac(il, inb(il)) = min(max(frac(il,inb(il)),0.), 1.)
    2558           fraci(il, inb(il)) = frac(il, inb(il))
    2559         ELSE
    2560           CONTINUE
    2561         END IF
    2562 
    25633009        IF (i<inb(il)) THEN
    2564 
    2565           IF (cvflag_ice) THEN
    2566 !CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15)
    2567             thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15)
    2568             thaw = min(max(thaw,0.0), 1.0)
    2569             frac(il, i) = frac(il, i)*(1.-thaw)
    2570           ELSE
    2571             CONTINUE
    2572           END IF
    2573 
    25743010          rp(il, i) = rp(il, i+1) + &
    25753011                      (cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il, i)
    25763012          rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
    25773013        END IF
    2578         fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15)
    2579         fraci(il, i) = min(max(fraci(il,i),0.0), 1.0)
    25803014        rp(il, i) = max(rp(il,i), 0.0)
    25813015        rp(il, i) = amin1(rp(il,i), rs(il,i))
    … …  
    29983432
    29993433  RETURN
     3434
    30003435END SUBROUTINE cv3_unsat
    30013436
    … …  
    30043439                     t, rr, t_wake, rr_wake, s_wake, u, v, tra, &
    30053440                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
    3006                      ep, clw, m, tp, mp, rp, up, vp, trap, &
     3441                     ep, clw, qpreca, m, tp, mp, rp, up, vp, trap, &
    30073442                     wt, water, ice, evap, fondue, faci, b, sigd, &
    30083443                     ment, qent, hent, iflag_mix, uent, vent, &
    … …  
    30143449!!                     tls, tps,                             ! useless . jyg
    30153450                     qcondc, wd, &
    3016                      ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
     3451                     ftd, fqd, qta, qtc, sigt, tau_cld_cv, coefw_cld_cv)
    30173452
    30183453    USE print_control_mod, ONLY: lunout, prt_level
    … …  
    30543489      REAL, DIMENSION (nloc, na, na, ntra), INTENT (IN)  :: traent
    30553490      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, wghti
    3056       REAL,INTENT(IN)                                    :: tau_cld_cv, coefw_cld_cv
     3491      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta
     3492      REAL, DIMENSION (nloc, na),INTENT(IN)              :: qpreca
     3493      REAL, INTENT(IN)                                   :: tau_cld_cv, coefw_cld_cv
    30573494!
    30583495!input/output:
    … …  
    30833520      REAL                                               :: ax, bx, cx, dx, ex
    30843521      REAL                                               :: cpinv, rdcp, dpinv
     3522      REAL                                               :: sigaq
    30853523      REAL, DIMENSION (nloc)                             ::  awat
    30863524      REAL, DIMENSION (nloc, nd)                         :: lvcp, lfcp              ! , mke ! unused . jyg
    … …  
    31003538      REAL, DIMENSION (nloc)                             :: sument
    31013539      REAL, DIMENSION (nloc, nd)                         :: sigment, qtment             ! cld
    3102       REAL, DIMENSION (nloc)                             :: qnk
    31033540      REAL sumdq !jyg
    31043541!
    … …  
    32113648  END DO
    32123649
     3650! - Adiabatic ascent mass flux "ma" and cloud base mass flux "cbmf"
     3651!-----------------------------------------------------------------
     3652!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3653  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
     3654!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3655!!! Warning : this option leads to water conservation violation
     3656!!!           Expert only
     3657!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3658  DO il = 1, ncum
     3659    ma(il, nlp) = 0.
     3660    ma(il, 1)   = 0.
     3661  END DO
     3662  DO k = nl, 2, -1
     3663    DO il = 1, ncum
     3664      ma(il, k) = ma(il, k+1)*(1.-qta(il, k))/(1.-qta(il, k-1)) + m(il, k)
     3665      cbmf(il) = max(cbmf(il), ma(il,k))
     3666    END DO
     3667  END DO
     3668  DO k = 2,nl
     3669    DO il = 1, ncum
     3670      IF (k <icb(il)) THEN
     3671        ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il)
     3672      ENDIF
     3673    END DO
     3674  END DO
     3675!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3676  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
     3677!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3678!! Line kept for compatibility with earlier versions
    32133679  DO k = 2, nl
    32143680    DO il = 1, ncum
    … …  
    32193685  END DO
    32203686
     3687  DO il = 1, ncum
     3688    ma(il, nlp) = 0.
     3689    ma(il, 1)   = 0.
     3690  END DO
     3691  DO k = nl, 2, -1
     3692    DO il = 1, ncum
     3693      ma(il, k) = ma(il, k+1) + m(il, k)
     3694    END DO
     3695  END DO
     3696  DO k = 2,nl
     3697    DO il = 1, ncum
     3698      IF (k <icb(il)) THEN
     3699        ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il)
     3700      ENDIF
     3701    END DO
     3702  END DO
     3703
     3704  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
     3705!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3706!
    32213707!    print*,'cv3_yield avant ft'
    32223708! am is the part of cbmf taken from the first level
    … …  
    33553841!***    Compute convective mass fluxes upwd and dnwd      ***
    33563842
     3843!
     3844! =================================================
     3845!              upward fluxes                      |
     3846! ------------------------------------------------
     3847!
    33573848upwd(:,:) = 0.
    33583849up_to(:,:) = 0.
    33593850up_from(:,:) = 0.
    3360 dnwd(:,:) = 0.
    3361 dn_to(:,:) = 0.
    3362 dn_from(:,:) = 0.
    3363 !
    3364 ! =================================================
    3365 !              upward fluxes                      |
    3366 ! ------------------------------------------------
     3851!
     3852!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3853  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
     3854!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3855!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation
     3856!! is taken into account.
     3857!! WARNING : in the present version, taking into account the mass-flux decrease due to
     3858!! precipitation ejection leads to water conservation violation.
     3859!
     3860! - Upward mass flux of mixed draughts
     3861!---------------------------------------
     3862DO i = 2, nl
     3863  DO j = 1, i-1
     3864    DO il = 1, ncum
     3865      IF (i<=inb(il)) THEN
     3866        up_to(il,i) = up_to(il,i) + ment(il,j,i)
     3867      ENDIF
     3868    ENDDO
     3869  ENDDO
     3870ENDDO
     3871!
     3872DO j = 3, nl
     3873  DO i = 2, j-1
     3874    DO il = 1, ncum
     3875      IF (j<=inb(il)) THEN
     3876        up_from(il,i) = up_from(il,i) + ment(il,i,j)
     3877      ENDIF
     3878    ENDDO
     3879  ENDDO
     3880ENDDO
     3881!
     3882! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer
     3883!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting
     3884!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)):
     3885!
     3886DO i = 2, nlp
     3887  DO il = 1, ncum
     3888    IF (i<=inb(il)+1) THEN
     3889      upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1))
     3890    ENDIF
     3891  ENDDO
     3892ENDDO
     3893!
     3894! - Total upward mass flux
     3895!---------------------------
     3896DO i = 2, nlp
     3897  DO il = 1, ncum
     3898    IF (i<=inb(il)+1) THEN
     3899      upwd(il,i) = upwd(il,i) + ma(il,i)
     3900    ENDIF
     3901  ENDDO
     3902ENDDO
     3903!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3904  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
     3905!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3906!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation
     3907!! is not taken into account.
     3908!
     3909! - Upward mass flux
     3910!-------------------
    33673911DO i = 2, nl
    33683912  DO il = 1, ncum
    … …  
    33873931  ENDDO
    33883932ENDDO
    3389 !!DO i = 2, nl
    3390 !!  DO j = i+1, nl          !! Permuter les boucles i et j
     3933!
    33913934DO j = 3, nl
    33923935  DO i = 2, j-1
    … …  
    34103953  ENDDO
    34113954ENDDO
     3955
     3956
     3957  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
     3958!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     3959
    34123960!
    34133961! =================================================
    34143962!              downward fluxes                    |
    34153963! ------------------------------------------------
     3964dnwd(:,:) = 0.
     3965dn_to(:,:) = 0.
     3966dn_from(:,:) = 0.
    34163967DO i = 1, nl
    34173968  DO j = i+1, nl
    … …  
    34243975ENDDO
    34253976!
    3426 !!DO i = 2, nl
    3427 !!  DO j = 1, i-1          !! Permuter les boucles i et j
    34283977DO j = 1, nl
    34293978  DO i = j+1, nl
    … …  
    37494298    END DO ! cld
    37504299
     4300!ym BIG Warning : it seems that the k loop is missing !!!
     4301!ym Strong advice to check this
     4302!ym add a k loop temporary
     4303
    37514304! (particular case: no detraining level is found)                              ! cld
     4305! Verif merge Dynamico<<<<<<< .working
    37524306    DO il = 1, ncum                                                            ! cld
    37534307      IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
    … …  
    37614315      END IF                                                                   ! cld
    37624316    END DO                                                                     ! cld
     4317! Verif merge Dynamico =======
     4318! Verif merge Dynamico     DO k = i + 1, nl
     4319! Verif merge Dynamico       DO il = 1, ncum        !ym k loop added                                    ! cld
     4320! Verif merge Dynamico         IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
     4321! Verif merge Dynamico           qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i)                 ! cld
     4322! Verif merge Dynamico           qtment(il, i) = qent(il,k,i) + qtment(il,i)                          ! cld
     4323! Verif merge Dynamico           nqcond(il, i) = nqcond(il, i) + 1.                                     ! cld
     4324! Verif merge Dynamico         END IF                                                                   ! cld
     4325! Verif merge Dynamico       END DO
     4326! Verif merge Dynamico     ENDDO                                                                     ! cld
     4327! Verif merge Dynamico >>>>>>> .merge-right.r3413
    37634328
    37644329    DO il = 1, ncum                                                            ! cld
    … …  
    41814746!!!!
    41824747!!!!      ENDDO
     4748
     4749!!  DO i = 1, nlp
     4750!!    DO il = 1, ncum
     4751!!      ma(il, i) = 0
     4752!!    END DO
     4753!!  END DO
     4754!!
     4755!!  DO i = 1, nl
     4756!!    DO j = i, nl
     4757!!      DO il = 1, ncum
     4758!!        ma(il, i) = ma(il, i) + m(il, j)
     4759!!      END DO
     4760!!    END DO
     4761!!  END DO
     4762
     4763!jyg<  (loops stop at nl)
     4764!!  DO i = nl + 1, nd
     4765!!    DO il = 1, ncum
     4766!!      ma(il, i) = 0.
     4767!!    END DO
     4768!!  END DO
     4769!>jyg
     4770
     4771!!  DO i = 1, nl
     4772!!    DO il = 1, ncum
     4773!!      IF (i<=(icb(il)-1)) THEN
     4774!!        ma(il, i) = 0
     4775!!      END IF
     4776!!    END DO
     4777!!  END DO
     4778
    41834779!-----------------------------------------------------------
    41844780        ENDIF !(.NOT.ok_optim_yield)                      !|
    … …  
    42054801!>jyg
    42064802
    4207   DO i = 1, nlp
    4208     DO il = 1, ncum
    4209       ma(il, i) = 0
    4210     END DO
    4211   END DO
    4212 
    4213   DO i = 1, nl
    4214     DO j = i, nl
    4215       DO il = 1, ncum
    4216         ma(il, i) = ma(il, i) + m(il, j)
    4217       END DO
    4218     END DO
    4219   END DO
    4220 
    4221 !jyg<  (loops stop at nl)
    4222 !!  DO i = nl + 1, nd
    4223 !!    DO il = 1, ncum
    4224 !!      ma(il, i) = 0.
    4225 !!    END DO
    4226 !!  END DO
    4227 !>jyg
    4228 
    4229   DO i = 1, nl
    4230     DO il = 1, ncum
    4231       IF (i<=(icb(il)-1)) THEN
    4232         ma(il, i) = 0
    4233       END IF
    4234     END DO
    4235   END DO
    42364803
    42374804! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    … …  
    43204887! 14/01/15 AJ delta n'a rien à faire là...                                                 
    43214888    DO il = 1, ncum                                                  ! cld
    4322       IF (wa(il,i)>0.0 .AND. iflag(il)<=1) &                         ! cld
     4889!!      IF (wa(il,i)>0.0 .AND. iflag(il)<=1) &                         ! cld
     4890!!        siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) &          ! cld
     4891!!        *rrd*tvp(il, i)/p(il, i)/100.                                ! cld
     4892!!
     4893!!      siga(il, i) = min(siga(il,i), 1.0)                             ! cld
     4894      sigaq = 0.
     4895      IF (wa(il,i)>0.0 .AND. iflag(il)<=1)  THEN                     ! cld
    43234896        siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) &          ! cld
    4324         *rrd*tvp(il, i)/p(il, i)/100.                                ! cld
    4325 
    4326       siga(il, i) = min(siga(il,i), 1.0)                             ! cld
     4897                     *rrd*tvp(il, i)/p(il, i)/100.                   ! cld
     4898        siga(il, i) = min(siga(il,i), 1.0)                           ! cld
     4899        sigaq = siga(il,i)*qta(il,i-1)                               ! cld
     4900      ENDIF
    43274901
    43284902! IM cf. FH
    … …  
    43364910        sigment(il,i)=sument(il)*tau_cld_cv/(ph(il,i)-ph(il,i+1))    ! cld
    43374911        sigment(il, i) = min(1.e-4+sigment(il,i), 1.0 - siga(il,i))  ! cld
    4338         qtc(il, i) = (siga(il,i)*qnk(il)+sigment(il,i)*qtment(il,i)) & ! cld
     4912!!        qtc(il, i) = (siga(il,i)*qta(il,i-1)+sigment(il,i)*qtment(il,i)) & ! cld
     4913        qtc(il, i) = (sigaq+sigment(il,i)*qtment(il,i)) & ! cld
    43394914                     /(siga(il,i)+sigment(il,i))                     ! cld
    43404915        sigt(il,i) = sigment(il, i) + siga(il, i)
    43414916
    4342 !        qtc(il, i) = siga(il,i)*qnk(il)+(1.-siga(il,i))*qtment(il,i) ! cld
     4917!        qtc(il, i) = siga(il,i)*qta(il,i-1)+(1.-siga(il,i))*qtment(il,i) ! cld
    43434918!     print*,'BIGAUSSIAN CONV',siga(il,i),sigment(il,i),qtc(il,i) 
    43444919               
    … …  
    46295204      do k=1,nl
    46305205        do i=1,ncum
    4631           hp(i,k)=h(i,k)
    4632         enddo
     5206          hp(i,k)=h(i,k)
     5207        enddo
    46335208      enddo
    46345209

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3a_uncompress.F90

    r2481 r3605  
    1010                           asupmaxmin, &
    1111                           da, phi, mp, phi2, d1a, dam, sigij, &                ! RomP+AC+jyg
    12                            clw, elij, evap, ep, epmlmMm, eplaMm, &              ! RomP
    13                            wdtrainA, wdtrainM, &                                ! RomP
     12                           qta, clw, elij, evap, ep, epmlmMm, eplaMm, &         ! RomP+jyg
     13                           wdtrainA, wdtrainS, wdtrainM, &                      ! RomP
    1414                           qtc, sigt,          &
    1515                           epmax_diag, & ! epmax_cape
    … …  
    2424                           asupmaxmin1, &
    2525                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1, &         ! RomP+AC+jyg
    26                            clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &        ! RomP
    27                            wdtrainA1, wdtrainM1, &                              ! RomP
     26                           qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &  ! RomP+jyg
     27                           wdtrainA1, wdtrainS1, wdtrainM1, &                   ! RomP
    2828                           qtc1, sigt1, &
    2929                           epmax_diag1) ! epmax_cape
    … …  
    7575  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: d1a, dam               !RomP
    7676  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: sigij                  !RomP
     77  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta                    !jyg
    7778  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: clw                    !RomP
    7879  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: elij                   !RomP
    … …  
    8182  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: eplamM                 !RomP+jyg
    8283  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qtc, sigt              !RomP
    83   REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wdtrainA, wdtrainM     !RomP
     84  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wdtrainA, wdtrainS, wdtrainM     !RomP
    8485
    8586  ! outputs:
    … …  
    111112  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1, dam1 !RomP       !RomP
    112113  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1                 !RomP
     114  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qta1                   !jyg
    113115  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1                   !RomP
    114116  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1                  !RomP
    … …  
    117119  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplamM1                !RomP+jyg
    118120  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1, sigt1            !RomP
    119   REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainM1   !RomP
     121  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainS1, wdtrainM1   !RomP
    120122
    121123
    … …  
    175177        d1a1(idcum(i), k) = d1a(i, k) !RomP
    176178        dam1(idcum(i), k) = dam(i, k) !RomP
     179        qta1(idcum(i), k) = qta(i, k) !jyg
    177180        clw1(idcum(i), k) = clw(i, k) !RomP
    178181        evap1(idcum(i), k) = evap(i, k) !RomP
    … …  
    180183        eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg
    181184        wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP
     185        wdtrainS1(idcum(i), k) = wdtrainS(i, k) !RomP
    182186        wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP
    183187        qtc1(idcum(i), k) = qtc(i, k)
    … …  
    300304      d1a1(:, 1:nl) = d1a(:, 1:nl)            !RomP
    301305      dam1(:, 1:nl) = dam(:, 1:nl)            !RomP
     306      qta1(:, 1:nl) = qta(:, 1:nl)            !jyg
    302307      clw1(:, 1:nl) = clw(:, 1:nl)            !RomP
    303308      evap1(:, 1:nl) = evap(:, 1:nl)          !RomP
    … …  
    305310      eplamM1(:, 1:nl) = eplamM(:, 1:nl)       !RomP+jyg
    306311      wdtrainA1(:, 1:nl) = wdtrainA(:, 1:nl)  !RomP
     312      wdtrainS1(:, 1:nl) = wdtrainS(:, 1:nl)  !RomP
    307313      wdtrainM1(:, 1:nl) = wdtrainM(:, 1:nl)  !RomP
    308314      qtc1(:, 1:nl) = qtc(:, 1:nl)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3p1_closure.F90

    r2826 r3605  
    537537    ELSE
    538538      ! Calculate wbeff
    539       IF (flag_wb==0) THEN
     539      IF (NINT(flag_wb)==0) THEN
    540540        wbeff(il) = wbmax
    541       ELSE IF (flag_wb==1) THEN
     541      ELSE IF (NINT(flag_wb)==1) THEN
    542542        wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
    543       ELSE IF (flag_wb==2) THEN
     543      ELSE IF (NINT(flag_wb)==2) THEN
    544544        wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
    545545      ELSE ! Option provisoire ou le iflag_wb/10 est considere comme une vitesse

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3p2_closure.F90

    r2502 r3605  
    2323  include "cvthermo.h"
    2424  include "cv3param.h"
     25  include "cvflag.h"
    2526  include "YOMCST2.h"
    2627  include "YOMCST.h"
    … …  
    608609    ELSE
    609610      ! Calculate wbeff
    610       IF (flag_wb==0) THEN
     611      IF (NINT(flag_wb)==0) THEN
    611612        wbeff(il) = wbmax
    612       ELSE IF (flag_wb==1) THEN
     613      ELSE IF (NINT(flag_wb)==1) THEN
    613614        wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
    614       ELSE IF (flag_wb==2) THEN
     615      ELSE IF (NINT(flag_wb)==2) THEN
    615616        wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
    616617      END IF

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3p_mixing.F90

    r2905 r3605  
    11SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
    2                        ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, &
     2                       ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, &
    33                       unk, vnk, hp, tv, tvp, ep, clw, sig, &
    44                       Ment, Qent, hent, uent, vent, nent, &
    … …  
    2929  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
    3030  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
    31   REAL, DIMENSION (nloc), INTENT (IN)                :: qnk, unk, vnk
     31  REAL, DIMENSION (nloc), INTENT (IN)                :: unk, vnk
     32  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta
    3233  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
    3334  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
    … …  
    173174                           .AND. (j<=inb(il))) THEN
    174175
    175             rti = qnk(il) - ep(il, i)*clw(il, i)
     176!!            rti = qnk(il) - ep(il, i)*clw(il, i)
     177            rti = qta(il,i-1) - ep(il, i)*clw(il, i)
    176178            bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
    177179!jyg(from aj)<
    … …  
    219221            Sij(il, i, j) = amax1(0.0, Sij(il,i,j))
    220222            Sij(il, i, j) = amin1(1.0, Sij(il,i,j))
     223          ELSE IF (j > i) THEN
     224            IF (prt_level >= 10) THEN
     225              print *,'cv3p_mixing i, j, Sij given by the no-precip eq. ', i, j, Sij(il,i,j)
     226            ENDIF
    221227          END IF ! new
    222228        END DO
    … …  
    248254!!!       Ment(il,i,i)=m(il,i)
    249255        Ment(il, i, i) = 1.
    250         Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
     256!!        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
     257        Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i)
    251258        uent(il, i, i) = unk(il)
    252259        vent(il, i, i) = vnk(il)
    … …  
    332339      IF (i>=icb(il) .AND. i<=inb(il)) THEN
    333340        lwork(il) = (nent(il,i)/=0)
    334         rti = qnk(il) - ep(il, i)*clw(il, i)
     341!!        rti = qnk(il) - ep(il, i)*clw(il, i)
     342        rti = qta(il,i-1) - ep(il, i)*clw(il, i)
    335343!jyg<
    336344        IF (cvflag_ice) THEN
    … …  
    462470            lwork(il)) THEN
    463471          IF (Sij(il,i,j)>0.0) THEN
    464             rti = qnk(il) - ep(il, i)*clw(il, i)
     472!!            rti = qnk(il) - ep(il, i)*clw(il, i)
     473            rti = qta(il,i-1) - ep(il, i)*clw(il, i)
    465474            Qmixmax(il) = Qmix(Sjmax(il))
    466475            Qmixmin(il) = Qmix(Sjmin(il))
    … …  
    590599              lwork(il)) THEN
    591600            IF (Sij(il,i,j)>0.0) THEN
    592               rti = qnk(il) - ep(il, i)*clw(il, i)
     601!!              rti = qnk(il) - ep(il, i)*clw(il, i)
     602              rti = qta(il,i-1) - ep(il, i)*clw(il, i)
    593603!!!             Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
    594604              Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
    … …  
    659669! cc        Ment(il,i,i)=m(il,i)
    660670        Ment(il, i, i) = 1.
    661         Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
     671!!        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
     672        Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i)
    662673        uent(il, i, i) = unk(il)
    663674        vent(il, i, i) = vnk(il)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv3param.h

    r2905 r3605  
    77!------------------------------------------------------------
    88
    9       logical ok_homo_tend
    10       logical ok_optim_yield
    11       logical ok_entrain
    12       logical ok_convstop
    13       logical ok_intermittent
     9      integer flag_epKEorig
     10      real flag_wb
     11      integer cv_flag_feed
    1412      integer noff, minorig, nl, nlp, nlm
    15       integer cv_flag_feed
    16       integer flag_epKEorig,flag_wb
    1713      real sigdz, spfac
    1814      real pbcrit, ptcrit
    … …  
    2723      real delta
    2824      real betad
     25      real ejectliq
     26      real ejectice
    2927
    3028      COMMON /cv3param/ sigdz, spfac &
    … …  
    3937                      ,wbmax &
    4038                      ,delta, betad  &
     39                      ,ejectliq, ejectice &
    4140                      ,flag_epKEorig &
    4241                      ,flag_wb, cv_flag_feed &
    43                       ,noff, minorig, nl, nlp, nlm  &
    44                       ,ok_convstop, ok_intermittent &
    45                       ,ok_optim_yield &
    46                       ,ok_entrain &
    47                       ,ok_homo_tend
     42                      ,noff, minorig, nl, nlp, nlm
    4843!$OMP THREADPRIVATE(/cv3param/)
    4944

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cv_driver.F90

    r3409 r3605  
    568568                ,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
    569569                ,epmax_diag)
    570         ! on écrase ep et recalcule hp
     570        ! on écrase ep et recalcule hp
    571571    END IF
    572572
    … …  
    681681! ==================================================================
    682682SUBROUTINE cv_flag(iflag_ice_thermo)
     683
     684  USE ioipsl_getin_p_mod, ONLY : getin_p
     685
    683686  IMPLICIT NONE
    684687
    … …  
    693696  cvflag_grav = .TRUE.
    694697  cvflag_ice = iflag_ice_thermo >= 1
     698  !
     699! si icvflag_Tpa=0, alors la fraction de glace dans l'ascendance adiabatique est
     700  ! fonction de la temperature de l'environnement et la temperature de l'ascendance est
     701  ! calculee en deux itérations, une en supposant qu'il n'y a pas de glace et l'autre
     702  ! en ajoutant la glace (ancien schéma d'Arnaud Jam).
     703! si icvflag_Tpa=1, alors la fraction de glace dans l'ascendance adiabatique est
     704  ! fonction de la temperature de l'environnement et la temperature de l'ascendance est
     705  ! calculee en une seule iteration.
     706! si icvflag_Tpa=2, alors la fraction de glace dans l'ascendance adiabatique est
     707  ! fonction de la temperature de l'ascendance et la temperature de l'ascendance est
     708  ! calculee en une seule iteration.
     709  icvflag_Tpa=0 
     710  call getin_p('icvflag_Tpa', icvflag_Tpa)
    695711
    696712  RETURN

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cva_driver.F90

    r3197 r3605  
    2525!!                      elij1,evap1,ep1,epmlmMm1,eplaMm1, &                ! RomP
    2626                      da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL
    27                       clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &        ! RomP, RL
    28                       wdtrainA1, wdtrainM1, qtc1, sigt1, tau_cld_cv, &
     27                      qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &  ! RomP, RL
     28                      wdtrainA1, wdtrainS1, wdtrainM1, qtc1, sigt1, tau_cld_cv, &     !!jygprl
    2929                      coefw_cld_cv, &                                      ! RomP, AJ
    3030                      epmax_diag1)  ! epmax_cape
    … …  
    124124!                                      of dimension ND, defined at same grid levels as T, Q, QS and P.
    125125
    126 ! wdtrainA1     Real           Output   precipitation detrained from adiabatic draught;
     126! wdtrainA1     Real           Output   precipitation ejected from adiabatic draught;
     127!                                         should be used in tracer transport (cvltr)
     128! wdtrainS1     Real           Output   precipitation detrained from shedding of adiabatic draught;
    127129!                                         used in tracer transport (cvltr)
    128130! wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
    … …  
    248250
    249251! RomP >>>
    250   REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainM1 ! precipitation sources (extensive)
     252  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainS1, wdtrainM1 ! precipitation sources (extensive)
    251253  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mp1  ! unsat. mass flux (staggered grid)
    252254  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1  ! detrained mass flux of adiab. asc. air (extensive)
    … …  
    258260  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1 ! mass fraction of env. air in mixed draughts (intensive)
    259261  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1! cond. water per unit mass of mixed draughts (intensive)
     262  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qta1 ! total water per unit mass of the adiab. asc. (intensive)
    260263  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1 ! cond. water per unit mass of the adiab. asc. (intensive)
    261264!JYG,RL
    … …  
    467470  REAL tv_wake(nloc, nd)
    468471  REAL clw(nloc, nd)
     472  REAL, DIMENSION(nloc, nd)    :: qta, qpreca                       !!jygprl
    469473  REAL dph(nloc, nd)
    470474  REAL pbase(nloc), buoybase(nloc), th(nloc, nd)
    … …  
    477481  REAL cin(nloc)
    478482  REAL m(nloc, nd)
     483  REAL mm(nloc, nd)
    479484  REAL ment(nloc, nd, nd), sigij(nloc, nd, nd)
    480485  REAL qent(nloc, nd, nd)
    … …  
    494499  REAL, DIMENSION(len,nd)     :: wt, water, evap
    495500  REAL, DIMENSION(len,nd)     :: ice, fondue, b
    496   REAL, DIMENSION(len,nd)     :: frac, faci
     501  REAL, DIMENSION(len,nd)     :: frac_a, frac_s, faci               !!jygprl
    497502  REAL ft(nloc, nd), fq(nloc, nd)
    498503  REAL ftd(nloc, nd), fqd(nloc, nd)
    … …  
    523528 
    524529! RomP >>>
    525   REAL wdtrainA(nloc, nd), wdtrainM(nloc, nd)
     530  REAL wdtrainA(nloc, nd), wdtrainS(nloc, nd), wdtrainM(nloc, nd)   !!jygprl
    526531  REAL da(len, nd), phi(len, nd, nd)
    527532  REAL epmlmMm(nloc, nd, nd), eplaMm(nloc, nd)
    … …  
    613618  asupmaxmin1(:) = 0.
    614619
     620  tvp(:, :) = 0. !ym missing init, need to have a look by developpers
     621  tv(:, :) = 0. !ym missing init, need to have a look by developpers
     622
    615623  DO il = 1, len
    616624    cin1(il) = -100000.
    … …  
    633641  qtc1(:, :) = 0.
    634642  wdtrainA1(:, :) = 0.
     643  wdtrainS1(:, :) = 0.
    635644  wdtrainM1(:, :) = 0.
    636645  da1(:, :) = 0.
    … …  
    643652  sigij1(:, :, :) = 0.
    644653  elij1(:, :, :) = 0.
     654  qta1(:,:) = 0.
    645655  clw1(:,:) = 0.
    646656  wghti1(:,:) = 0.
    … …  
    903913                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
    904914                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
    905                          frac)
     915                         frac_a, frac_s, qpreca, qta)                        !!jygprl
    906916    END IF
    907917
    … …  
    912922                        tnk, qnk, gznk, t, q, qs, gz, &
    913923                        p, dph, h, tv, lv, &
    914                         inb, inbis, tp, tvp, clw, hp, ep, sigp, frac)
     924                        inb, inbis, tp, tvp, clw, hp, ep, sigp, frac_s)
    915925    END IF
    916926
    … …  
    920930             PRINT *, 'cva_driver -> cv3_epmax_cape'
    921931    call cv3_epmax_fn_cape(nloc,ncum,nd &
    922                 , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac &
     932                , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac_s &
    923933                , pbase, p, ph, tv, buoy, sig, w0,iflag &
    924934                , epmax_diag)
    … …  
    938948             PRINT *, 'cva_driver -> cv3p_mixing'
    939949        CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &           ! na->nd
    940                          ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
     950!!                         ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
     951                         ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qta, &      !!jygprl
    941952                         unk, vnk, hp, tv, tvp, ep, clw, sig, &
    942953                         ment, qent, hent, uent, vent, nent, &
    … …  
    10181029             PRINT *, 'cva_driver -> cv3_mixing'
    10191030        CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &             ! na->nd
    1020                         ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
     1031                        ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qnk, &
    10211032                        unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
    10221033                        ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent)
    10231034        CALL zilch(hent, nloc*nd*nd)
    10241035      ELSE
    1025         CALL cv3_mixscale(nloc, ncum, nd, ment, m)
     1036!!jyg:  Essais absurde pour voir
     1037!!        mm(:,1) = 0.
     1038!!        DO  i = 2,nd
     1039!!          mm(:,i) = m(:,i)*(1.-qta(:,i-1))
     1040!!        ENDDO
     1041        mm(:,:) = m(:,:)
     1042        CALL cv3_mixscale(nloc, ncum, nd, ment, mm)
    10261043        IF (debut) THEN
    10271044          PRINT *, ' cv3_mixscale-> '
    … …  
    10591076                     t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, &
    10601077                     th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, &
    1061                      ep, sigp, clw, &
     1078                     ep, sigp, clw, frac_s, qpreca, frac_a, qta, &                    !!jygprl
    10621079                     m, ment, elij, delt, plcl, coef_clos, &
    10631080                     mp, qp, up, vp, trap, wt, water, evap, fondue, ice, &
    10641081                     faci, b, sigd, &
    1065                      wdtrainA, wdtrainM)                                       ! RomP
     1082!!                     wdtrainA, wdtrainM)                                       ! RomP
     1083                     wdtrainA, wdtrainS, wdtrainM)                               !!jygprl
    10661084!
    10671085      IF (prt_level >= 10) THEN
    … …  
    10721090           evap(igout,k), fondue(igout,k)
    10731091        ENDDO
    1074         Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainM '
     1092        Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainS, wdtrainM '     !!jygprl
    10751093        DO k = 1,nd
    1076         write (6, '(i4,2(1x,e13.6))'), &
    1077            k, wdtrainA(igout,k), wdtrainM(igout,k)
     1094        write (6, '(i4,3(1x,e13.6))'), &
     1095           k, wdtrainA(igout,k), wdtrainS(igout,k), wdtrainM(igout,k)            !!jygprl
    10781096        ENDDO
    10791097      ENDIF
    … …  
    11091127                     t, q, t_wake, q_wake, s_wake, u, v, tra, &
    11101128                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
    1111                      ep, clw, m, tp, mp, qp, up, vp, trap, &
     1129                     ep, clw, qpreca, m, tp, mp, qp, up, vp, trap, &
    11121130                     wt, water, ice, evap, fondue, faci, b, sigd, &
    11131131                     ment, qent, hent, iflag_mix, uent, vent, &
    … …  
    11181136!!                     tls, tps, &                            ! useless . jyg
    11191137                     qcondc, wd, &
    1120                      ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
     1138!!                     ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
     1139                     ftd, fqd, qta, qtc, sigt, tau_cld_cv, coefw_cld_cv)         !!jygprl
     1140!
     1141!         Test conseravtion de l'eau
    11211142!
    11221143      IF (debut) THEN
    … …  
    11391160                     t, q, u, v, &
    11401161                     gz, p, ph, h, hp, lv, cpn, &
    1141                      ep, clw, frac, m, mp, qp, up, vp, &
     1162                     ep, clw, frac_s, m, mp, qp, up, vp, &
    11421163                     wt, water, evap, &
    11431164                     ment, qent, uent, vent, nent, elij, &
    … …  
    11841205                           asupmaxmin, &
    11851206                           da, phi, mp, phi2, d1a, dam, sigij, &         ! RomP
    1186                            clw, elij, evap, ep, epmlmMm, eplaMm, &       ! RomP
    1187                            wdtrainA, wdtrainM, &                         ! RomP
     1207                           qta, clw, elij, evap, ep, epmlmMm, eplaMm, &  ! RomP
     1208                           wdtrainA, wdtrainS, wdtrainM, &                         ! RomP
    11881209                           qtc, sigt, epmax_diag, & ! epmax_cape
    11891210                           iflag1, kbas1, ktop1, &
    … …  
    11961217                           Plim11, plim21, asupmax1, supmax01, &
    11971218                           asupmaxmin1, &
    1198                            da1, phi1, mp1, phi21, d1a1, dam1, sigij1,  & ! RomP
    1199                            clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP
    1200                            wdtrainA1, wdtrainM1,                       & ! RomP
     1219                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1,  &       ! RomP
     1220                           qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP
     1221                           wdtrainA1, wdtrainS1, wdtrainM1,                  & ! RomP
    12011222                           qtc1, sigt1, epmax_diag1) ! epmax_cape
    12021223!   

  • LMDZ6/branches/Ocean_skin/libf/phylmd/cvflag.h

    r1992 r3605  
    44      logical cvflag_grav
    55      logical cvflag_ice
     6      logical ok_optim_yield
     7      logical ok_entrain
     8      logical ok_homo_tend
     9      logical ok_convstop
     10      logical ok_intermittent
     11      logical cvflag_prec_eject
     12      logical qsat_depends_on_qt
     13      logical adiab_ascent_mass_flux_depends_on_ejectliq
     14      logical keepbug_ice_frac
     15      integer icvflag_Tpa
    616
    7       COMMON /cvflag/ cvflag_grav, cvflag_ice 
     17      COMMON /cvflag/ icvflag_Tpa, &
     18                      cvflag_grav, cvflag_ice, &
     19                      ok_optim_yield, &
     20                      ok_entrain, &
     21                      ok_homo_tend, &
     22                      ok_convstop, ok_intermittent, &
     23                      cvflag_prec_eject, &
     24                      qsat_depends_on_qt, &
     25                      adiab_ascent_mass_flux_depends_on_ejectliq, &
     26                      keepbug_ice_frac
    827!$OMP THREADPRIVATE(/cvflag/)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/dimphy.F90

    • Property svn:keywords changed from Author Date Id Revision to Id
    r2656 r3605  
    1 MODULE dimphy
     1!
     2! $Id$
     3!
     4  MODULE dimphy
    25 
    36  INTEGER,SAVE :: klon
    … …  
    3336!$OMP END MASTER   
    3437    ALLOCATE(zmasq(klon))   
     38    zmasq=0.
    3539   
    3640  END SUBROUTINE Init_dimphy
    3741
     42  SUBROUTINE Init_dimphy1D(klon0,klev0)
     43! 1D special version of dimphy without ALLOCATE(zmasq)
     44! which will be allocated in iniphysiq
     45  IMPLICIT NONE
     46 
     47    INTEGER, INTENT(in) :: klon0
     48    INTEGER, INTENT(in) :: klev0
     49   
     50    klon=klon0
     51    kdlon=klon
     52    kidia=1
     53    kfdia=klon
     54    klev=klev0
     55    klevp1=klev+1
     56    klevm1=klev-1
     57    kflev=klev
     58   
     59  END SUBROUTINE Init_dimphy1D
     60
    3861 
    3962END MODULE dimphy

  • 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                &

  • LMDZ6/branches/Ocean_skin/libf/phylmd/fisrtilp.F90

    r2969 r3605  
    740740               call cloudth(klon,klev,k,ztv, &
    741741                   zq,zqta,fraca, &
    742                    qcloud,ctot,zpspsk,paprs,ztla,zthl, &
     742                   qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
    743743                   ratqs,zqs,t)
    744               elseif (iflag_cloudth_vert>=3) then
     744              elseif (iflag_cloudth_vert>=3 .and. iflag_cloudth_vert<=5) then
    745745               call cloudth_v3(klon,klev,k,ztv, &
    746746                   zq,zqta,fraca, &
    747                    qcloud,ctot,ctot_vol,zpspsk,paprs,ztla,zthl, &
     747                   qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
    748748                   ratqs,zqs,t)
     749              !----------------------------------
     750              !Version these Jean Jouhaud, Decembre 2018
     751              !----------------------------------             
     752              elseif (iflag_cloudth_vert==6) then
     753               call cloudth_v6(klon,klev,k,ztv, &
     754                   zq,zqta,fraca, &
     755                   qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
     756                   ratqs,zqs,t)
     757
    749758              endif
    750759              do i=1,klon

  • LMDZ6/branches/Ocean_skin/libf/phylmd/flott_gwd_rando_m.F90

    • Property svn:keywords set to Id
    r3198 r3605  
     1!
     2! $Id$
     3!
    14module FLOTT_GWD_rando_m
    25
    … …  
    2023      USE ioipsl_getin_p_mod, ONLY : getin_p
    2124      USE vertical_layers_mod, ONLY : presnivs
     25      CHARACTER (LEN=20) :: modname='flott_gwd_rando'
     26      CHARACTER (LEN=80) :: abort_message
    2227
    2328      include "YOMCST.h"
    … …  
    115120    LOGICAL, SAVE :: firstcall = .TRUE.
    116121  !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp)
    117 
    118     CHARACTER (LEN=20) :: modname='flott_gwd_rando'
    119     CHARACTER (LEN=80) :: abort_message
    120 
    121122
    122123
    … …  
    198199
    199200    IF(DELTAT < DTIME)THEN
    200        PRINT *, 'flott_gwd_rando: deltat < dtime!'
    201        STOP 1
     201       abort_message='flott_gwd_rando: deltat < dtime!'
     202       CALL abort_physic(modname,abort_message,1)
    202203    ENDIF
    203204
    204205    IF (KLEV < NW) THEN
    205        PRINT *, 'flott_gwd_rando: you will have problem with random numbers'
    206        STOP 1
     206       abort_message='flott_gwd_rando: you will have problem with random numbers'
     207       CALL abort_physic(modname,abort_message,1)
    207208    ENDIF
    208209

  • LMDZ6/branches/Ocean_skin/libf/phylmd/geo2atm.F90

    r2429 r3605  
    55  USE dimphy
    66  USE mod_phys_lmdz_para
    7 
     7  USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat
    88  IMPLICIT NONE
    99  INCLUDE 'YOMCST.h'
     10  CHARACTER (len = 6)                :: clmodnam
     11  CHARACTER (len = 20)               :: modname = 'geo2atm'
     12  CHARACTER (len = 80)               :: abort_message
    1013
    1114! Change wind coordinates from cartesian geocentric to local spherical
    1215! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP)
    1316!
     17! Geocentric :
     18  ! axe x is eastward : crosses (0N,90E) point.
     19  ! axe y  crosses (0N,180E) point.
     20  ! axe z is 'up' : crosses north pole.
     21!
     22! NB! Aux poles, fonctionne probablement uniquement en MPI seul (sans OpenMP)
     23
    1424  INTEGER, INTENT (IN)                 :: im, jm
    1525  REAL, DIMENSION (im,jm), INTENT(IN)  :: px, py, pz
    … …  
    1727  REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr
    1828
    19   REAL :: rad
     29  REAL :: rad,reps
    2030
    2131
    2232  rad = rpi / 180.0E0
    23  
     33  reps = 1.0e-5
     34
    2435  pu(:,:) = &
    2536       - px(:,:) * SIN(rad * plon(:,:)) &
    … …  
    3647       + pz(:,:) * SIN(rad * plat(:,:))
    3748
    38   ! Value at North Pole
    39   IF (is_north_pole_dyn) THEN
    40      pu(:, 1) = -px (1,1)
    41      pv(:, 1) = -py (1,1)
    42      pr(:, 1) = 0.0
    43   ENDIF
     49  IF (grid_type==regular_lonlat) THEN
     50    ! Value at North Pole
     51    IF (is_north_pole_dyn) THEN
     52       pu(:, 1) = -px (1,1)
     53       pv(:, 1) = -py (1,1)
     54       pr(:, 1) = 0.0
     55    ENDIF
    4456 
    45   ! Value at South Pole     
    46   IF (is_south_pole_dyn) THEN
    47      pu(:,jm) = -px (1,jm)
    48      pv(:,jm) = -py (1,jm)
    49      pr(:,jm) = 0.0
    50   ENDIF
     57    ! Value at South Pole     
     58    IF (is_south_pole_dyn) THEN
     59       pu(:,jm) = -px (1,jm)
     60       pv(:,jm) = -py (1,jm)
     61       pr(:,jm) = 0.0
     62    ENDIF
     63
     64  ELSE IF (grid_type==unstructured) THEN
     65     ! Pole nord pour Dynamico
     66     WHERE ( plat(:,:) >= 90.0-reps )
     67        pu(:,:) =  py(:,:)
     68        pv(:,:) = -px(:,:)
     69        pr(:,:) = 0.0e0
     70     END WHERE
     71
     72  ELSE
     73     abort_message='Problem: unknown grid type'
     74     CALL abort_physic(modname,abort_message,1)
     75  END IF
     76
     77 
     78 
    5179 
    5280END SUBROUTINE geo2atm

  • LMDZ6/branches/Ocean_skin/libf/phylmd/grid_noro_m.F90

    r2665 r3605  
     1!
     2! $Id$
     3!
    14MODULE grid_noro_m
    25!
    … …  
    334337  imar=assert_eq(SIZE(x),SIZE(zphi,1),SIZE(mask,1),TRIM(modname)//" imar")-1
    335338  jmar=assert_eq(SIZE(y),SIZE(zphi,2),SIZE(mask,2),TRIM(modname)//" jmar")
    336 ! IF(imar/=iim)   CALL abort_gcm(TRIM(modname),'imar/=iim'  ,1)
    337 ! IF(jmar/=jjm+1) CALL abort_gcm(TRIM(modname),'jmar/=jjm+1',1)
    338339  iext=imdp/10
    339340  xpi = ACOS(-1.)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/ini_undefSTD.F90

    r2346 r3605  
    5555
    5656    IF (n==1 .AND. itap-itapm1==1 .OR. n>1 .AND. mod(itap,nint( &
    57         freq_outnmc(n)/dtime))==1) THEN
     57        freq_outnmc(n)/phys_tstep))==1) THEN
    5858      ! print*,'ini_undefSTD n itap',n,itap
    5959      DO k = 1, nlevstd

  • LMDZ6/branches/Ocean_skin/libf/phylmd/inifis_mod.F90

    r2311 r3605  
    66  SUBROUTINE inifis(punjours, prad, pg, pr, pcpp)
    77  ! Initialize some physical constants and settings
    8   USE print_control_mod, ONLY: init_print_control, lunout
     8  USE init_print_control_mod, ONLY : init_print_control
     9  USE print_control_mod, ONLY: lunout
    910  IMPLICIT NONE
    1011

  • LMDZ6/branches/Ocean_skin/libf/phylmd/iophy.F90

    r3266 r3605  
    1818#ifdef CPP_XIOS
    1919  INTERFACE histwrite_phy
    20 !#ifdef CPP_XIOSnew
    2120    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios,histwrite0d_xios
    22 !#else
    23 !    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios
    24 !#endif
    25 
    2621  END INTERFACE
    2722#else
    … …  
    5247                                  mpi_size, mpi_rank, klon_mpi, &
    5348                                is_sequential, is_south_pole_dyn
    54     USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
    55     USE print_control_mod, ONLY: prt_level,lunout
     49  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid_type, unstructured
     50  USE print_control_mod, ONLY: prt_level,lunout
    5651#ifdef CPP_IOIPSL
    5752    USE ioipsl, ONLY: flio_dom_set
    5853#endif
    5954#ifdef CPP_XIOS
    60     USE wxios, ONLY: wxios_domain_param
     55  use wxios, ONLY: wxios_domain_param, wxios_domain_param_unstructured, wxios_context_init
    6156#endif
    6257    IMPLICIT NONE
    … …  
    7772    INTEGER :: data_ibegin, data_iend
    7873
    79     CALL gather(rlat,rlat_glo)
    80     CALL bcast(rlat_glo)
    81     CALL gather(rlon,rlon_glo)
    82     CALL bcast(rlon_glo)
     74#ifdef CPP_XIOS
     75      CALL wxios_context_init
     76#endif
     77   
     78
     79    IF (grid_type==unstructured) THEN
     80   
     81#ifdef CPP_XIOS
     82      CALL wxios_domain_param_unstructured("dom_glo")
     83#endif
     84
     85    ELSE
     86
     87      CALL gather(rlat,rlat_glo)
     88      CALL bcast(rlat_glo)
     89      CALL gather(rlon,rlon_glo)
     90      CALL bcast(rlon_glo)
    8391   
    8492!$OMP MASTER 
    … …  
    133141#endif
    134142#ifdef CPP_XIOS
    135     ! Set values for the mask:
    136     IF (mpi_rank == 0) THEN
    137         data_ibegin = 0
    138     ELSE
    139         data_ibegin = ii_begin - 1
    140     ENDIF
    141 
    142     IF (mpi_rank == mpi_size-1) THEN
    143         data_iend = nbp_lon
    144     ELSE
    145         data_iend = ii_end + 1
    146     ENDIF
    147 
    148     IF (prt_level>=10) THEN
    149       write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," iibegin=",ii_begin , " ii_end=",ii_end," jjbegin=",jj_begin," jj_nb=",jj_nb," jj_end=",jj_end
    150       write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat
    151       write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
    152       write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
    153       write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn
    154     ENDIF
    155 
    156     ! Initialize the XIOS domain coreesponding to this process:
    157     CALL wxios_domain_param("dom_glo", is_sequential, nbp_lon, jj_nb, nbp_lon, nbp_lat, &
    158                             1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end,             &
    159                             klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend,             &
    160                             io_lat, io_lon,is_south_pole_dyn,mpi_rank)
     143      ! Set values for the mask:
     144      IF (mpi_rank == 0) THEN
     145          data_ibegin = 0
     146      ELSE
     147          data_ibegin = ii_begin - 1
     148      END IF
     149
     150      IF (mpi_rank == mpi_size-1) THEN
     151          data_iend = nbp_lon
     152      ELSE
     153          data_iend = ii_end + 1
     154      END IF
     155
     156      IF (prt_level>=10) THEN
     157        write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," iibegin=",ii_begin , " ii_end=",ii_end," jjbegin=",jj_begin," jj_nb=",jj_nb," jj_end=",jj_end
     158        write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat
     159        write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
     160        write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
     161        write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole_dyn=",is_south_pole_dyn
     162      ENDIF
     163
     164      ! Initialize the XIOS domain coreesponding to this process:
    161165#endif
    162166!$OMP END MASTER
     167
     168#ifdef CPP_XIOS   
     169        CALL wxios_domain_param("dom_glo")
     170#endif
     171     
     172    ENDIF
    163173     
    164174  END SUBROUTINE init_iophy_new
    … …  
    291301                                is_sequential, klon_mpi_begin, klon_mpi_end, &
    292302                                mpi_rank
    293   USE mod_grid_phy_lmdz, ONLY: klon_glo, nbp_lon, nbp_lat
     303  USE mod_grid_phy_lmdz, ONLY: klon_glo, nbp_lon, nbp_lat, grid1dTo2d_glo
    294304  USE ioipsl, ONLY: histbeg
    295305
    … …  
    366376     ENDDO
    367377
    368        CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon_glo,zx_lon)
     378       CALL grid1dTo2d_glo(rlon_glo,zx_lon)
    369379       IF ((nbp_lon*nbp_lat).GT.1) THEN
    370380       DO i = 1, nbp_lon
    … …  
    373383       ENDDO
    374384       ENDIF
    375        CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat_glo,zx_lat)
     385       CALL grid1dTo2d_glo(rlat_glo,zx_lat)
    376386
    377387    DO i=1,pim
    … …  
    963973                                 nid_files, swaerofree_diag, swaero_diag, dryaod_diag, ok_4xCO2atm
    964974  USE print_control_mod, ONLY: prt_level,lunout
    965   USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
     975  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
    966976#ifdef CPP_XIOS
    967977  USE xios, ONLY: xios_send_field
    968978#endif
     979  USE print_control_mod, ONLY: lunout, prt_level
    969980
    970981  IMPLICIT NONE
    … …  
    10071018      IF (.not. ok_all_xml) THEN
    10081019      IF (prt_level >= 10) THEN
    1009       WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", trim(var%name)
     1020      write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", &
     1021                     trim(var%name)
    10101022      ENDIF
    10111023      DO iff=iff_beg, iff_end
    … …  
    10251037
    10261038    !Et sinon on.... écrit
    1027     IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1)   
     1039    IF (SIZE(field)/=klon .AND. SIZE(field)/=klev .AND. SIZE(field)/=klev+1) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1)   
    10281040    IF (prt_level >= 10) THEn
    10291041      WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", trim(var%name)
    … …  
    10371049    ENDIF
    10381050!$OMP MASTER
    1039     CALL grid1Dto2D_mpi(buffer_omp,Field2d)
     1051    IF (grid_type==regular_lonlat) CALL grid1Dto2D_mpi(buffer_omp,Field2d)
    10401052
    10411053! La boucle sur les fichiers:
    … …  
    10471059             write(lunout,*)'Dans iophy histwrite2D,var%name ', trim(var%name)                       
    10481060          ENDIF
    1049           IF (SIZE(field) == klon) then
     1061         
     1062          IF (grid_type==regular_lonlat) THEN
     1063            IF (SIZE(field) == klon) then
    10501064              CALL xios_send_field(var%name, Field2d)
    1051           ELSE
    1052              CALL xios_send_field(var%name, field)
    1053           ENDIF
     1065            ELSE
     1066               CALL xios_send_field(var%name, field)
     1067            ENDIF
     1068          ELSE IF (grid_type==unstructured) THEN
     1069            IF (SIZE(field) == klon) then
     1070              CALL xios_send_field(var%name, buffer_omp)
     1071            ELSE
     1072               CALL xios_send_field(var%name, field)
     1073            ENDIF
     1074
     1075          ENDIF
    10541076          IF (prt_level >= 10) THEN
    1055              WRITE (lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ', trim(var%name)                       
     1077             write(lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ',&
     1078                             trim(var%name)                       
    10561079          ENDIF
    10571080#else
    … …  
    10651088               IF (firstx) THEN
    10661089                  IF (prt_level >= 10) THEN
    1067                      WRITE (lunout,*)'Dans iophy histwrite2D,iff,var%name ', iff,trim(var%name)                       
    1068                      WRITE (lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
     1090                     write(lunout,*)'Dans iophy histwrite2D,iff,var%name ',&
     1091                                    iff,trim(var%name)                       
     1092                     write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
    10691093                  ENDIF
    1070                   IF (SIZE(field) == klon) then
    1071                      CALL xios_send_field(var%name, Field2d)
    1072                   ELSE
    1073                      CALL xios_send_field(var%name, field)
     1094                  IF (grid_type==regular_lonlat) THEN
     1095                    IF (SIZE(field) == klon) then
     1096                       CALL xios_send_field(var%name, Field2d)
     1097                    ELSE
     1098                       CALL xios_send_field(var%name, field)
     1099                    ENDIF
     1100                  ELSE IF (grid_type==unstructured) THEN
     1101                    IF (SIZE(field) == klon) then
     1102                      CALL xios_send_field(var%name, buffer_omp)
     1103                    ELSE
     1104                      CALL xios_send_field(var%name, field)
     1105                    ENDIF
    10741106                  ENDIF
     1107
    10751108                  firstx=.false.
    10761109               ENDIF
    … …  
    10851118!#ifdef CPP_XIOS
    10861119!                        IF (iff == iff_beg) THEN
    1087 !                          if (prt_level >= 10) then
     1120!                          IF (prt_level >= 10) THEN
    10881121!                            write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
    1089 !                          endif
     1122!                          ENDIF
    10901123!                          CALL xios_send_field(var%name, Field2d)
    10911124!                        ENDIF
    … …  
    11091142                       ENDIF ! of IF (is_sequential)
    11101143#ifndef CPP_IOIPSL_NO_OUTPUT
    1111                        IF (prt_level >= 10) THEn
     1144                       IF (prt_level >= 10) THEN
    11121145                         write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
    11131146                       ENDIF
    … …  
    11411174                                 nfiles, vars_defined, clef_stations, &
    11421175                                 nid_files, swaerofree_diag
    1143   USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
     1176  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, regular_lonlat, unstructured
    11441177#ifdef CPP_XIOS
    11451178  USE xios, ONLY: xios_send_field
    … …  
    11911224    !Et sinon on.... écrit
    11921225
    1193     IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
     1226    IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev .AND. SIZE(field,1)/=klev+1) CALL abort_physic('iophy::histwrite3d_phy','Field first DIMENSION not equal to klon/klev',1)
    11941227
    11951228    nlev=SIZE(field,2)
    … …  
    12061239    ENDIF
    12071240!$OMP MASTER
    1208     CALL grid1Dto2D_mpi(buffer_omp,field3d)
     1241    IF (grid_type==regular_lonlat) CALL grid1Dto2D_mpi(buffer_omp,field3d)
    12091242
    12101243! BOUCLE SUR LES FICHIERS
    … …  
    12131246    IF (ok_all_xml) THEN
    12141247#ifdef CPP_XIOS
    1215         IF (prt_level >= 10) THEN
    1216              write(lunout,*)'Dans iophy histwrite3D,var%name ',trim(var%name)                       
     1248          IF (prt_level >= 10) THEN
     1249             write(lunout,*)'Dans iophy histwrite3D,var%name ',&
     1250                             trim(var%name)                       
     1251          ENDIF
     1252          IF (grid_type==regular_lonlat) THEN
     1253            IF (SIZE(field,1) == klon) then
     1254               CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
     1255            ELSE
     1256               CALL xios_send_field(var%name, field)
     1257            ENDIF
     1258          ELSE IF (grid_type==unstructured) THEN
     1259            IF (SIZE(field,1) == klon) then
     1260               CALL xios_send_field(var%name, buffer_omp(:,1:nlevx))
     1261            ELSE
     1262               CALL xios_send_field(var%name, field)
     1263            ENDIF
    12171264        ENDIF
    1218         IF (SIZE(field,1) == klon) then
    1219              CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
    1220         ELSE
    1221              CALL xios_send_field(var%name, field)
    1222         ENDIF
     1265
    12231266#else
    12241267        CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
    … …  
    12301273#ifdef CPP_XIOS
    12311274              IF (firstx) THEN
    1232                 IF (prt_level >= 10) THEn
    1233                   WRITE (lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
     1275                IF (prt_level >= 10) THEN
     1276                  write(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
    12341277                                  iff,nlev,klev, firstx                       
    1235                   WRITE (lunout,*)'histwrite3d_phy: call xios_send_field for ', &
     1278                  write(lunout,*)'histwrite3d_phy: call xios_send_field for ', &
    12361279                                  trim(var%name), ' with iim jjm nlevx = ', &
    12371280                                  nbp_lon,jj_nb,nlevx
    12381281                ENDIF
    1239                 IF (SIZE(field,1) == klon) then
    1240                     CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
    1241                 ELSE
     1282                IF (grid_type==regular_lonlat) THEN
     1283                  IF (SIZE(field,1) == klon) then
     1284                      CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
     1285                  ELSE
     1286                       CALL xios_send_field(var%name, field)
     1287                  ENDIF
     1288                ELSE IF (grid_type==unstructured) THEN
     1289                  IF (SIZE(field,1) == klon) then
     1290                     CALL xios_send_field(var%name, buffer_omp(:,1:nlevx))
     1291                  ELSE
    12421292                     CALL xios_send_field(var%name, field)
     1293                  ENDIF
    12431294                ENDIF
     1295
    12441296                firstx=.false.
    12451297              ENDIF
    … …  
    13051357                                is_sequential, klon_mpi_begin, klon_mpi_end, &
    13061358                                jj_nb, klon_mpi, is_master
    1307   USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
     1359  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, unstructured
    13081360  USE xios, ONLY: xios_send_field
    13091361  USE print_control_mod, ONLY: prt_level,lunout
    … …  
    13251377  IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
    13261378
    1327   !Et sinon on.... écrit
    1328   IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1)
    1329    
    1330   IF (SIZE(field) == klev) then
     1379    !Et sinon on.... écrit
     1380    IF (SIZE(field)/=klon .AND. SIZE(field)/=klev .AND. SIZE(field)/=klev+1) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1)
     1381    IF (SIZE(field) == klev .OR. SIZE(field) == klev+1) then
    13311382!$OMP MASTER
     1383
    13321384        CALL xios_send_field(field_name,field)
    13331385!$OMP END MASTER   
    … …  
    13351387        CALL Gather_omp(field,buffer_omp)   
    13361388!$OMP MASTER
     1389
     1390      IF (grid_type==unstructured) THEN
     1391 
     1392        CALL xios_send_field(field_name, buffer_omp)
     1393
     1394      ELSE
     1395
    13371396        CALL grid1Dto2D_mpi(buffer_omp,Field2d)
    13381397   
    … …  
    13421401    !IF(.NOT.clef_stations(iff)) THEN
    13431402        IF (.TRUE.) THEN
    1344             ALLOCATE(index2d(nbp_lon*jj_nb))
    1345             ALLOCATE(fieldok(nbp_lon*jj_nb))
    1346    
    13471403   
    13481404            CALL xios_send_field(field_name, Field2d)
    … …  
    13651421                ENDDO
    13661422            ENDIF
    1367    
    1368         ENDIF
    1369                  
    1370         DEALLOCATE(index2d)
    1371         DEALLOCATE(fieldok)
     1423            DEALLOCATE(index2d)
     1424            DEALLOCATE(fieldok)
     1425   
     1426        ENDIF                 
     1427      ENDIF
    13721428!$OMP END MASTER   
    13731429  ENDIF
    … …  
    13851441                                jj_nb, klon_mpi, is_master
    13861442  USE xios, ONLY: xios_send_field
    1387   USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
     1443  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, unstructured
    13881444  USE print_control_mod, ONLY: prt_level,lunout
    13891445
    … …  
    14031459  IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
    14041460
    1405   !Et on.... écrit
    1406   IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
    1407    
    1408   IF (SIZE(field,1) == klev) then
     1461    !Et on.... écrit
     1462    IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev .AND. SIZE(field,1)/=klev+1) then
     1463      write(lunout,*)' histrwrite3d_xios ', field_name, SIZE(field)
     1464      CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
     1465    ENDIF
     1466   
     1467    IF (SIZE(field,1) == klev .OR. SIZE(field,1) == klev+1) then
    14091468!$OMP MASTER
    14101469        CALL xios_send_field(field_name,field)
    … …  
    14161475        CALL Gather_omp(field,buffer_omp)
    14171476!$OMP MASTER
     1477
     1478    IF (grid_type==unstructured) THEN
     1479
     1480      CALL xios_send_field(field_name, buffer_omp(:,1:nlev))
     1481
     1482    ELSE
    14181483        CALL grid1Dto2D_mpi(buffer_omp,field3d)
    14191484
    … …  
    14231488    !IF (.NOT.clef_stations(iff)) THEN
    14241489        IF(.TRUE.)THEN
    1425             ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
    1426             ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
    1427             CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
     1490
     1491           CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
    14281492                           
    14291493        ELSE
    … …  
    14481512                ENDDO
    14491513            ENDIF
     1514            DEALLOCATE(index3d)
     1515            DEALLOCATE(fieldok)
    14501516        ENDIF
    1451         DEALLOCATE(index3d)
    1452         DEALLOCATE(fieldok)
     1517      ENDIF
    14531518!$OMP END MASTER   
    14541519  ENDIF

  • LMDZ6/branches/Ocean_skin/libf/phylmd/iostart.F90

    r3401 r3605  
    2525
    2626    PUBLIC get_field,get_var,put_field,put_var
    27     PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy
     27    PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy, enddef_restartphy
    2828   
    2929CONTAINS
    … …  
    117117  USE netcdf
    118118  USE dimphy
     119  USE geometry_mod
    119120  USE mod_grid_phy_lmdz
    120121  USE mod_phys_lmdz_para
    … …  
    125126    LOGICAL,OPTIONAL :: found
    126127   
    127     REAL    :: field_glo(klon_glo,field_size)
     128    REAL,ALLOCATABLE    :: field_glo(:,:)
     129    REAL,ALLOCATABLE    :: field_glo_tmp(:,:)
     130    INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
    128131    LOGICAL :: tmp_found
    129132    INTEGER :: varid
    130     INTEGER :: ierr
    131    
    132     IF (is_mpi_root .AND. is_omp_root) THEN
     133    INTEGER :: ierr,i
     134
     135    IF (is_master) THEN
     136      ALLOCATE(ind_cell_glo_glo(klon_glo))
     137      ALLOCATE(field_glo(klon_glo,field_size))
     138      ALLOCATE(field_glo_tmp(klon_glo,field_size))
     139    ELSE
     140      ALLOCATE(ind_cell_glo_glo(0))
     141      ALLOCATE(field_glo(0,0))
     142    ENDIF
     143   
     144    CALL gather(ind_cell_glo,ind_cell_glo_glo)
     145   
     146    IF (is_master) THEN
    133147 
    134148      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
    135149     
    136150      IF (ierr==NF90_NOERR) THEN
    137         CALL body(field_glo)
     151        CALL body(field_glo_tmp)
    138152        tmp_found=.TRUE.
    139153      ELSE
    … …  
    146160
    147161    IF (tmp_found) THEN
     162      IF (is_master) THEN 
     163        DO i=1,klon_glo
     164         field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
     165        ENDDO
     166      ENDIF
    148167      CALL scatter(field_glo,field)
    149168    ENDIF
    … …  
    307326      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
    308327
    309       ierr = NF90_ENDDEF(nid_restart)
     328!      ierr = NF90_ENDDEF(nid_restart)
    310329    ENDIF
    311330
    312331  END SUBROUTINE open_restartphy
    313332 
     333  SUBROUTINE enddef_restartphy
     334  USE netcdf
     335  USE mod_phys_lmdz_para
     336  IMPLICIT NONE
     337    INTEGER          :: ierr
     338
     339    IF (is_master) ierr = NF90_ENDDEF(nid_restart)
     340 
     341  END SUBROUTINE enddef_restartphy
     342
    314343  SUBROUTINE close_restartphy
    315344  USE netcdf
    … …  
    318347    INTEGER          :: ierr
    319348
    320     IF (is_mpi_root .AND. is_omp_root) THEN
    321       ierr = NF90_CLOSE (nid_restart)
    322     ENDIF
     349    IF (is_master) ierr = NF90_CLOSE (nid_restart)
    323350 
    324351  END SUBROUTINE close_restartphy
    325352
    326353 
    327   SUBROUTINE put_field_r1(field_name,title,field)
    328   IMPLICIT NONE
     354  SUBROUTINE put_field_r1(pass, field_name,title,field)
     355  IMPLICIT NONE
     356  INTEGER, INTENT(IN)            :: pass
    329357  CHARACTER(LEN=*),INTENT(IN)    :: field_name
    330358  CHARACTER(LEN=*),INTENT(IN)    :: title
    331359  REAL,INTENT(IN)                :: field(:)
    332  
    333     CALL put_field_rgen(field_name,title,field,1)
     360    CALL put_field_rgen(pass, field_name,title,field,1)
    334361 
    335362  END SUBROUTINE put_field_r1
    336363
    337   SUBROUTINE put_field_r2(field_name,title,field)
    338   IMPLICIT NONE
     364  SUBROUTINE put_field_r2(pass, field_name,title,field)
     365  IMPLICIT NONE
     366  INTEGER, INTENT(IN)            :: pass
    339367  CHARACTER(LEN=*),INTENT(IN)    :: field_name
    340368  CHARACTER(LEN=*),INTENT(IN)    :: title
    341369  REAL,INTENT(IN)                :: field(:,:)
    342370 
    343     CALL put_field_rgen(field_name,title,field,size(field,2))
     371    CALL put_field_rgen(pass, field_name,title,field,size(field,2))
    344372 
    345373  END SUBROUTINE put_field_r2
    346374
    347   SUBROUTINE put_field_r3(field_name,title,field)
    348   IMPLICIT NONE
     375  SUBROUTINE put_field_r3(pass, field_name,title,field)
     376  IMPLICIT NONE
     377  INTEGER, INTENT(IN)            :: pass
    349378  CHARACTER(LEN=*),INTENT(IN)    :: field_name
    350379  CHARACTER(LEN=*),INTENT(IN)    :: title
    351380  REAL,INTENT(IN)                :: field(:,:,:)
    352381 
    353     CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
     382    CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3))
    354383 
    355384  END SUBROUTINE put_field_r3
    356385 
    357   SUBROUTINE put_field_rgen(field_name,title,field,field_size)
     386  SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size)
    358387  USE netcdf
    359388  USE dimphy
     389  USE geometry_mod
    360390  USE mod_grid_phy_lmdz
    361391  USE mod_phys_lmdz_para
    362392  IMPLICIT NONE
     393  INTEGER, INTENT(IN)            :: pass
    363394  CHARACTER(LEN=*),INTENT(IN)    :: field_name
    364395  CHARACTER(LEN=*),INTENT(IN)    :: title
    … …  
    366397  REAL,INTENT(IN)                :: field(klon,field_size)
    367398 
    368   REAL                           :: field_glo(klon_glo,field_size)
    369   INTEGER                        :: ierr
     399!  REAL                           :: field_glo(klon_glo,field_size)
     400!  REAL                           :: field_glo_tmp(klon_glo,field_size)
     401  REAL ,ALLOCATABLE              :: field_glo(:,:)
     402  REAL ,ALLOCATABLE              :: field_glo_tmp(:,:)
     403  INTEGER,ALLOCATABLE            :: ind_cell_glo_glo(:)
     404!  INTEGER                        :: ind_cell_glo_glo(klon_glo)
     405  INTEGER                        :: ierr,i
    370406  INTEGER                        :: nvarid
    371407  INTEGER                        :: idim
    372408   
    373    
    374     CALL gather(field,field_glo)
    375    
    376     IF (is_mpi_root .AND. is_omp_root) THEN
     409! first pass : definition   
     410  IF (pass==1) THEN
     411   
     412    IF (is_master) THEN
    377413
    378414      IF (field_size==1) THEN
    … …  
    387423      ENDIF
    388424         
    389       ierr = NF90_REDEF (nid_restart)
     425!      ierr = NF90_REDEF (nid_restart)
    390426#ifdef NC_DOUBLE
    391427      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
    … …  
    394430#endif
    395431      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
    396       ierr = NF90_ENDDEF(nid_restart)
    397       ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
    398     ENDIF
    399    
    400    END SUBROUTINE put_field_rgen 
    401  
    402    SUBROUTINE put_var_r0(var_name,title,var)
     432!      ierr = NF90_ENDDEF(nid_restart)
     433     ENDIF
     434
     435! second pass : write     
     436   ELSE IF (pass==2) THEN
     437   
     438     IF (is_master) THEN
     439       ALLOCATE(ind_cell_glo_glo(klon_glo))
     440       ALLOCATE(field_glo(klon_glo,field_size))
     441       ALLOCATE(field_glo_tmp(klon_glo,field_size))
     442     ELSE
     443       ALLOCATE(ind_cell_glo_glo(0))
     444       ALLOCATE(field_glo_tmp(0,0))
     445     ENDIF
     446     
     447     CALL gather(ind_cell_glo,ind_cell_glo_glo)
     448
     449     CALL gather(field,field_glo_tmp)
     450   
     451     IF (is_master) THEN
     452
     453       DO i=1,klon_glo
     454         field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
     455       ENDDO
     456
     457       ierr = NF90_INQ_VARID(nid_restart, field_name, nvarid)
     458       ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
     459      ENDIF
     460   ENDIF
     461   
     462 END SUBROUTINE put_field_rgen 
     463 
     464
     465 SUBROUTINE put_var_r0(pass, var_name,title,var)
    403466   IMPLICIT NONE
     467     INTEGER, INTENT(IN)            :: pass
    404468     CHARACTER(LEN=*),INTENT(IN) :: var_name
    405469     CHARACTER(LEN=*),INTENT(IN) :: title
    … …  
    409473     varin(1)=var
    410474     
    411      CALL put_var_rgen(var_name,title,varin,size(varin))
     475     CALL put_var_rgen(pass, var_name,title,varin,size(varin))
    412476
    413477  END SUBROUTINE put_var_r0
    414478
    415479
    416    SUBROUTINE put_var_r1(var_name,title,var)
     480   SUBROUTINE put_var_r1(pass, var_name,title,var)
    417481   IMPLICIT NONE
     482     INTEGER, INTENT(IN)            :: pass
    418483     CHARACTER(LEN=*),INTENT(IN) :: var_name
    419484     CHARACTER(LEN=*),INTENT(IN) :: title
    420485     REAL,INTENT(IN)             :: var(:)
    421486     
    422      CALL put_var_rgen(var_name,title,var,size(var))
     487     CALL put_var_rgen(pass, var_name,title,var,size(var))
    423488
    424489  END SUBROUTINE put_var_r1
    425490 
    426   SUBROUTINE put_var_r2(var_name,title,var)
     491  SUBROUTINE put_var_r2(pass, var_name,title,var)
    427492   IMPLICIT NONE
     493     INTEGER, INTENT(IN)            :: pass
    428494     CHARACTER(LEN=*),INTENT(IN) :: var_name
    429495     CHARACTER(LEN=*),INTENT(IN) :: title
    430496     REAL,INTENT(IN)             :: var(:,:)
    431497     
    432      CALL put_var_rgen(var_name,title,var,size(var))
     498     CALL put_var_rgen(pass, var_name,title,var,size(var))
    433499
    434500  END SUBROUTINE put_var_r2     
    435501 
    436   SUBROUTINE put_var_r3(var_name,title,var)
     502  SUBROUTINE put_var_r3(pass, var_name,title,var)
    437503   IMPLICIT NONE
     504     INTEGER, INTENT(IN)            :: pass
    438505     CHARACTER(LEN=*),INTENT(IN) :: var_name
    439506     CHARACTER(LEN=*),INTENT(IN) :: title
    440507     REAL,INTENT(IN)             :: var(:,:,:)
    441508     
    442      CALL put_var_rgen(var_name,title,var,size(var))
     509     CALL put_var_rgen(pass, var_name,title,var,size(var))
    443510
    444511  END SUBROUTINE put_var_r3
    445512
    446   SUBROUTINE put_var_rgen(var_name,title,var,var_size)
     513  SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size)
    447514  USE netcdf
    448515  USE dimphy
    449516  USE mod_phys_lmdz_para
    450517  IMPLICIT NONE
    451      CHARACTER(LEN=*),INTENT(IN) :: var_name
    452      CHARACTER(LEN=*),INTENT(IN) :: title
    453      INTEGER,INTENT(IN)          :: var_size
    454      REAL,INTENT(IN)             :: var(var_size)
    455      
    456      INTEGER :: ierr
    457      INTEGER :: nvarid
     518    INTEGER, INTENT(IN)         :: pass
     519    CHARACTER(LEN=*),INTENT(IN) :: var_name
     520    CHARACTER(LEN=*),INTENT(IN) :: title
     521    INTEGER,INTENT(IN)          :: var_size
     522    REAL,INTENT(IN)             :: var(var_size)
     523   
     524    INTEGER :: ierr
     525    INTEGER :: nvarid
    458526         
    459     IF (is_mpi_root .AND. is_omp_root) THEN
     527    IF (is_master) THEN
    460528
    461529      IF (var_size/=length) THEN
    … …  
    463531        call abort_physic("", "", 1)
    464532      ENDIF
    465      
    466       ierr = NF90_REDEF (nid_restart)
     533
     534     ! first pass : definition   
     535      IF (pass==1) THEN
     536       
     537!      ierr = NF90_REDEF (nid_restart)
    467538
    468539#ifdef NC_DOUBLE
    469       ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
     540        ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
    470541#else
    471       ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
     542        ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
    472543#endif
    473       IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
    474       ierr = NF90_ENDDEF(nid_restart)
    475      
    476       ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
    477 
     544        IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
     545!      ierr = NF90_ENDDEF(nid_restart)
     546
     547    ! second pass : write     
     548      ELSE IF (pass==2) THEN
     549        ierr = NF90_INQ_VARID(nid_restart, var_name, nvarid)
     550        ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
     551      ENDIF
    478552    ENDIF
    479553   

  • LMDZ6/branches/Ocean_skin/libf/phylmd/limit_read_mod.F90

    r2788 r3605  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44MODULE limit_read_mod
    … …  
    3131!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    3232
     33
     34  SUBROUTINE init_limit_read(first_day)
     35  USE mod_grid_phy_lmdz
     36  USE surface_data
     37  USE mod_phys_lmdz_para
     38#ifdef CPP_XIOS
     39  USE XIOS
     40#endif
     41  IMPLICIT NONE
     42    INTEGER, INTENT(IN) :: first_day
     43   
     44   
     45    IF ( type_ocean /= 'couple') THEN
     46      IF (grid_type==unstructured) THEN
     47#ifdef CPP_XIOS
     48        IF (is_omp_master) CALL xios_set_file_attr("limit_read",enabled=.TRUE.,record_offset=first_day)
     49#endif
     50      ENDIF 
     51    ENDIF
     52
     53  END SUBROUTINE init_limit_read
     54 
    3355  SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified)
    3456!
    … …  
    150172    USE phys_cal_mod, ONLY : calend, year_len
    151173    USE print_control_mod, ONLY: lunout, prt_level
    152 
     174#ifdef CPP_XIOS
     175    USE XIOS, ONLY: xios_recv_field
     176#endif
     177   
    153178    IMPLICIT NONE
    154179   
    … …  
    179204    REAL, DIMENSION(klon_glo)                 :: rug_glo  ! rugosity at global grid
    180205    REAL, DIMENSION(klon_glo)                 :: alb_glo  ! albedo at global grid
     206
     207    REAL, DIMENSION(klon_mpi,nbsrf)           :: pct_mpi  ! fraction at global grid
     208    REAL, DIMENSION(klon_mpi)                 :: sst_mpi  ! sea-surface temperature at global grid
     209    REAL, DIMENSION(klon_mpi)                 :: rug_mpi  ! rugosity at global grid
     210    REAL, DIMENSION(klon_mpi)                 :: alb_mpi  ! albedo at global grid
     211
    181212    CHARACTER(len=20)                         :: modname='limit_read_mod'     
    182213    CHARACTER(LEN=99)                         :: abort_message, calendar, str
    … …  
    220251          END IF
    221252
    222           !--- ERROR IF FILE RECORDS NUMBER IS NOT EQUAL TO EXPECTED NUMBER OF DAYS
    223           ierr=NF90_INQUIRE(nid, UnlimitedDimID=ndimid)
     253          !--- ERROR IF FILE RECORDS NUMBER IS NOT EQUAL TO EXPECTED NUMBER OF DAYS         
     254          IF (grid_type==unstructured) THEN
     255            ierr=NF90_INQ_DIMID(nid,"time_year",ndimid)
     256          ELSE
     257            ierr=NF90_INQUIRE(nid, UnlimitedDimID=ndimid)
     258          ENDIF
    224259          ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn)
    225           WRITE(abort_message,'(a,2(i3,a))')'limit.nc records number (',nn,') does no'//&
     260          WRITE(abort_message,'(a,2(i0,a))')'limit.nc records number (',nn,') does no'//&
    226261            't match year length (',year_len,')'
    227262          IF(nn/=year_len) CALL abort_physic(modname,abort_message,1)
    228263
    229264          !--- ERROR IF FILES AND LMDZ HORIZONTAL RESOLUTIONS DO NOT MATCH
    230           ierr=NF90_INQ_DIMID(nid, 'points_physiques', ndimid)
     265          IF (grid_type==unstructured) THEN
     266            ierr=NF90_INQ_DIMID(nid, 'cell', ndimid)
     267          ELSE
     268            ierr=NF90_INQ_DIMID(nid, 'points_physiques', ndimid)
     269          ENDIF
    231270          ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn)
    232271          WRITE(abort_message,'(a,2(i0,a))')'limit.nc horizontal number of cells (',nn, &
    … …  
    249288
    250289    is_modified = .FALSE.
    251     IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN   ! time to read
     290!ym    IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN   ! time to read
     291!  not REALLY PERIODIC
     292    IF (MOD(itime-1, lmt_pas) == 0 .OR. (jour_lu /= jour .AND. grid_type /= unstructured)) THEN   ! time to read
     293!    IF (MOD(itime-1, lmt_pas) == 0) THEN   ! time to read
    252294       jour_lu = jour
    253295       is_modified = .TRUE.
     296
     297      IF (grid_type==unstructured) THEN
     298
     299#ifdef CPP_XIOS
     300        IF ( type_ocean /= 'couple') THEN
     301
     302           IF (is_omp_master) CALL xios_recv_field("foce_limin",pct_mpi(:,is_oce))
     303           IF (is_omp_master) CALL xios_recv_field("fsic_limin",pct_mpi(:,is_sic))
     304  !         IF (read_continents .OR. itime == 1) THEN
     305           IF (is_omp_master) CALL xios_recv_field("fter_limin",pct_mpi(:,is_ter))
     306           IF (is_omp_master) CALL xios_recv_field("flic_limin",pct_mpi(:,is_lic))
     307  !         ENDIF
     308         ENDIF! type_ocean /= couple
     309         
     310         IF ( type_ocean /= 'couple') THEN                   
     311             IF (is_omp_master) CALL xios_recv_field("sst_limin",sst_mpi)
     312         ENDIF
     313       
     314         IF (.NOT. ok_veget) THEN
     315           IF (is_omp_master) CALL xios_recv_field("alb_limin",alb_mpi)
     316           IF (is_omp_master) CALL xios_recv_field("rug_limin",rug_mpi)
     317         ENDIF
     318
     319       IF ( type_ocean /= 'couple') THEN
     320          CALL Scatter_omp(sst_mpi,sst)
     321          CALL Scatter_omp(pct_mpi(:,is_oce),pctsrf(:,is_oce))
     322          CALL Scatter_omp(pct_mpi(:,is_sic),pctsrf(:,is_sic))
     323!          IF (read_continents .OR. itime == 1) THEN
     324             CALL Scatter_omp(pct_mpi(:,is_ter),pctsrf(:,is_ter))
     325             CALL Scatter_omp(pct_mpi(:,is_lic),pctsrf(:,is_lic))
     326!          END IF
     327       END IF
     328
     329       IF (.NOT. ok_veget) THEN
     330          CALL Scatter_omp(alb_mpi, albedo)
     331          CALL Scatter_omp(rug_mpi, rugos)
     332       END IF
     333#endif
     334
     335 
     336     ELSE      ! grid_type==regular
     337
    254338!$OMP MASTER  ! Only master thread
    255        IF (is_mpi_root) THEN ! Only master processus
     339       IF (is_mpi_root) THEN ! Only master processus!
    256340
    257341          ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid)
    … …  
    371455       END IF
    372456
     457      ENDIF ! Grid type
     458
    373459    ENDIF ! time to read
    374460

  • LMDZ6/branches/Ocean_skin/libf/phylmd/mo_simple_plumes.F90

    r3297 r3605  
    7878    !
    7979    INTEGER :: iret, ncid, DimID, VarID, xdmy
     80    CHARACTER (len = 50)     :: modname = 'mo_simple_plumes.sp_setup'
     81    CHARACTER (len = 80)     :: abort_message
     82
    8083    !
    8184    ! ----------
    … …  
    8487       !   
    8588       iret = nf90_open("MACv2.0-SP_v1.nc", NF90_NOWRITE, ncid)
    86        IF (iret /= NF90_NOERR) STOP 'NetCDF File not opened'
     89       IF (iret /= NF90_NOERR) THEN
     90          abort_message='NetCDF File not opened'
     91          CALL abort_physic(modname,abort_message,1)
     92       ENDIF
    8793       !
    8894       ! read dimensions and make sure file conforms to expected size
    … …  
    9096       iret = nf90_inq_dimid(ncid, "plume_number"  , DimId)
    9197       iret = nf90_inquire_dimension(ncid, DimId, len = xdmy)
    92        IF (xdmy /= nplumes) STOP 'NetCDF improperly dimensioned -- plume_number'
     98       IF (xdmy /= nplumes) THEN
     99          abort_message='NetCDF improperly dimensioned -- plume_number'
     100          CALL abort_physic(modname,abort_message,1)
     101       ENDIF
    93102       !
    94103       iret = nf90_inq_dimid(ncid, "plume_feature", DimId)
    95104       iret = nf90_inquire_dimension(ncid, DimId, len = xdmy)
    96        IF (xdmy /= nfeatures) STOP 'NetCDF improperly dimensioned -- plume_feature'
     105       IF (xdmy /= nfeatures) THEN
     106          abort_message='NetCDF improperly dimensioned -- plume_feature'
     107          CALL abort_physic(modname,abort_message,1)
     108       ENDIF
    97109       !
    98110       iret = nf90_inq_dimid(ncid, "year_fr"   , DimId)
    99111       iret = nf90_inquire_dimension(ncid, DimID, len = xdmy)
    100        IF (xdmy /= ntimes) STOP 'NetCDF improperly dimensioned -- year_fr'
     112       IF (xdmy /= ntimes) THEN
     113          abort_message='NetCDF improperly dimensioned -- year_fr'
     114          CALL abort_physic(modname,abort_message,1)
     115       ENDIF
    101116       !
    102117       iret = nf90_inq_dimid(ncid, "years"   , DimId)
    103118       iret = nf90_inquire_dimension(ncid, DimID, len = xdmy)
    104        IF (xdmy /= nyears) STOP 'NetCDF improperly dimensioned -- years'
     119       IF (xdmy /= nyears) THEN
     120          abort_message='NetCDF improperly dimensioned -- years'
     121          CALL abort_physic(modname,abort_message,1)
     122       ENDIF
    105123       !
    106124       ! read variables that define the simple plume climatology
    … …  
    108126       iret = nf90_inq_varid(ncid, "plume_lat", VarId)
    109127       iret = nf90_get_var(ncid, VarID, plume_lat(:), start=(/1/),count=(/nplumes/))
    110        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading plume_lat'
     128       IF (iret /= NF90_NOERR) THEN
     129          abort_message='NetCDF Error reading plume_lat'
     130          CALL abort_physic(modname,abort_message,1)
     131       ENDIF
    111132       iret = nf90_inq_varid(ncid, "plume_lon", VarId)
    112133       iret = nf90_get_var(ncid, VarID, plume_lon(:), start=(/1/),count=(/nplumes/))
    113        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading plume_lon'
     134       IF (iret /= NF90_NOERR) THEN
     135          abort_message='NetCDF Error reading plume_lon'
     136          CALL abort_physic(modname,abort_message,1)
     137       ENDIF
    114138       iret = nf90_inq_varid(ncid, "beta_a"   , VarId)
    115139       iret = nf90_get_var(ncid, VarID, beta_a(:)   , start=(/1/),count=(/nplumes/))
    116        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading beta_a'
     140       IF (iret /= NF90_NOERR) THEN
     141          abort_message='NetCDF Error reading beta_a'
     142          CALL abort_physic(modname,abort_message,1)
     143       ENDIF
    117144       iret = nf90_inq_varid(ncid, "beta_b"   , VarId)
    118145       iret = nf90_get_var(ncid, VarID, beta_b(:)   , start=(/1/),count=(/nplumes/))
    119        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading beta_b'
     146       IF (iret /= NF90_NOERR) THEN
     147          abort_message='NetCDF Error reading beta_b'
     148          CALL abort_physic(modname,abort_message,1)
     149       ENDIF
    120150       iret = nf90_inq_varid(ncid, "aod_spmx" , VarId)
    121151       iret = nf90_get_var(ncid, VarID, aod_spmx(:)  , start=(/1/),count=(/nplumes/))
    122        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading aod_spmx'
     152       IF (iret /= NF90_NOERR) THEN
     153          abort_message='NetCDF Error reading aod_spmx'
     154          CALL abort_physic(modname,abort_message,1)
     155       ENDIF
    123156       iret = nf90_inq_varid(ncid, "aod_fmbg" , VarId)
    124157       iret = nf90_get_var(ncid, VarID, aod_fmbg(:)  , start=(/1/),count=(/nplumes/))
    125        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading aod_fmbg'
     158       IF (iret /= NF90_NOERR) THEN
     159          abort_message='NetCDF Error reading aod_fmbg'
     160          CALL abort_physic(modname,abort_message,1)
     161       ENDIF
    126162       iret = nf90_inq_varid(ncid, "ssa550"   , VarId)
    127163       iret = nf90_get_var(ncid, VarID, ssa550(:)  , start=(/1/),count=(/nplumes/))
    128        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading ssa550'
     164       IF (iret /= NF90_NOERR) THEN
     165          abort_message='NetCDF Error reading ssa550'
     166          CALL abort_physic(modname,abort_message,1)
     167       ENDIF
    129168       iret = nf90_inq_varid(ncid, "asy550"   , VarId)
    130169       iret = nf90_get_var(ncid, VarID, asy550(:)  , start=(/1/),count=(/nplumes/))
    131        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading asy550'
     170       IF (iret /= NF90_NOERR) THEN
     171          abort_message='NetCDF Error reading asy550'
     172          CALL abort_physic(modname,abort_message,1)
     173       ENDIF
    132174       iret = nf90_inq_varid(ncid, "angstrom" , VarId)
    133175       iret = nf90_get_var(ncid, VarID, angstrom(:), start=(/1/),count=(/nplumes/))
    134        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading angstrom'
     176       IF (iret /= NF90_NOERR) THEN
     177          abort_message='NetCDF Error reading angstrom'
     178          CALL abort_physic(modname,abort_message,1)
     179       ENDIF
    135180       !
    136181       iret = nf90_inq_varid(ncid, "sig_lat_W"     , VarId)
    137182       iret = nf90_get_var(ncid, VarID, sig_lat_W(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
    138        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lat_W'
     183       IF (iret /= NF90_NOERR) THEN
     184          abort_message='NetCDF Error reading sig_lat_W'
     185          CALL abort_physic(modname,abort_message,1)
     186       ENDIF
    139187       iret = nf90_inq_varid(ncid, "sig_lat_E"     , VarId)
    140188       iret = nf90_get_var(ncid, VarID, sig_lat_E(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
    141        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lat_E'
     189       IF (iret /= NF90_NOERR) THEN
     190          abort_message='NetCDF Error reading sig_lat_E'
     191          CALL abort_physic(modname,abort_message,1)
     192       ENDIF
    142193       iret = nf90_inq_varid(ncid, "sig_lon_E"     , VarId)
    143194       iret = nf90_get_var(ncid, VarID, sig_lon_E(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
    144        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lon_E'
     195       IF (iret /= NF90_NOERR) THEN
     196          abort_message='NetCDF Error reading sig_lon_E'
     197          CALL abort_physic(modname,abort_message,1)
     198       ENDIF
    145199       iret = nf90_inq_varid(ncid, "sig_lon_W"     , VarId)
    146200       iret = nf90_get_var(ncid, VarID, sig_lon_W(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
    147        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lon_W'
     201       IF (iret /= NF90_NOERR) THEN
     202          abort_message='NetCDF Error reading sig_lon_W'
     203          CALL abort_physic(modname,abort_message,1)
     204       ENDIF
    148205       iret = nf90_inq_varid(ncid, "theta"         , VarId)
    149206       iret = nf90_get_var(ncid, VarID, theta(:,:)        , start=(/1,1/),count=(/nfeatures,nplumes/))
    150        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading theta'
     207       IF (iret /= NF90_NOERR) THEN
     208          abort_message='NetCDF Error reading theta'
     209          CALL abort_physic(modname,abort_message,1)
     210       ENDIF
    151211       iret = nf90_inq_varid(ncid, "ftr_weight"    , VarId)
    152212       iret = nf90_get_var(ncid, VarID, ftr_weight(:,:)   , start=(/1,1/),count=(/nfeatures,nplumes/))
    153        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading plume_lat'
     213       IF (iret /= NF90_NOERR) THEN
     214          abort_message='NetCDF Error reading plume_lat'
     215          CALL abort_physic(modname,abort_message,1)
     216       ENDIF
    154217       iret = nf90_inq_varid(ncid, "year_weight"   , VarId)
    155218       iret = nf90_get_var(ncid, VarID, year_weight(:,:)  , start=(/1,1/),count=(/nyears,nplumes   /))
    156        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading year_weight'
     219       IF (iret /= NF90_NOERR) THEN
     220          abort_message='NetCDF Error reading year_weight'
     221          CALL abort_physic(modname,abort_message,1)
     222       ENDIF
    157223       iret = nf90_inq_varid(ncid, "ann_cycle"     , VarId)
    158224       iret = nf90_get_var(ncid, VarID, ann_cycle(:,:,:)  , start=(/1,1,1/),count=(/nfeatures,ntimes,nplumes/))
    159        IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading ann_cycle'
     225       IF (iret /= NF90_NOERR) THEN
     226          abort_message='NetCDF Error reading ann_cycle'
     227          CALL abort_physic(modname,abort_message,1)
     228       ENDIF
    160229       !
    161230       iret = nf90_close(ncid)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/mod_synchro_omp.F90

    • Property svn:keywords changed from Author Date Id Revision to Id
    r1907 r3605  
     1!
     2! $Id$
     3!
    14MODULE mod_synchro_omp
    25
    … …  
    2124  IMPLICIT NONE
    2225  LOGICAL :: out
     26  CHARACTER (LEN=20) :: modname='synchro_omp'
     27  CHARACTER (LEN=80) :: abort_message
    2328 
    2429    out=.FALSE.
    … …  
    4651
    4752    IF (exit_omp/=0) THEN
    48       STOP 'synchro_omp'
     53       abort_message='synchro_omp'
     54       CALL abort_physic(modname,abort_message,1)
    4955    ENDIF
    5056

  • LMDZ6/branches/Ocean_skin/libf/phylmd/moy_undefSTD.F90

    r2380 r3605  
    7575
    7676    IF (n==1 .AND. itap==itapm1 .OR. n>1 .AND. mod(itap,nint(freq_outnmc(n)/ &
    77         dtime))==0) THEN
     77        phys_tstep))==0) THEN
    7878
    7979      ! print*,'moy_undefSTD n itap itapm1',n,itap,itapm1
    … …  
    140140        END DO !i
    141141      END DO !k
    142     END IF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0
     142    END IF !MOD(itap,NINT(freq_outNMC(n)/phys_tstep)).EQ.0
    143143
    144144  END DO !n

  • LMDZ6/branches/Ocean_skin/libf/phylmd/oasis.F90

    r3102 r3605  
    104104#ifdef CPP_XIOS
    105105    USE wxios, ONLY : wxios_context_init
     106    USE xios 
    106107#endif
    107108    USE print_control_mod, ONLY: lunout
    108     USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
     109    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
     110    USE geometry_mod, ONLY: ind_cell_glo                   
     111    USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
     112   
     113
    109114
    110115! Local variables
    … …  
    113118    INTEGER                            :: ierror, il_commlocal
    114119    INTEGER                            :: il_part_id
    115     INTEGER, DIMENSION(3)              :: ig_paral
     120    INTEGER, ALLOCATABLE               :: ig_paral(:)
    116121    INTEGER, DIMENSION(2)              :: il_var_nodims
    117122    INTEGER, DIMENSION(4)              :: il_var_actual_shape
    … …  
    136141! Define the model name
    137142!
    138     clmodnam = 'LMDZ'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
     143    IF (grid_type==unstructured) THEN
     144        clmodnam = 'icosa'                 ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
     145    ELSE IF (grid_type==regular_lonlat) THEN
     146        clmodnam = 'LMDZ'                  ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
     147    ELSE
     148        abort_message='Pb : type of grid unknown'
     149        CALL abort_physic(modname,abort_message,1)
     150    ENDIF
    139151
    140152
    … …  
    236248! Domain decomposition
    237249!************************************************************************************
    238     ig_paral(1) = 1                            ! apple partition for //
    239     ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1  ! offset
    240     ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1
    241 
    242     IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
     250    IF (grid_type==unstructured) THEN
     251
     252      ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) )
     253
     254      ig_paral(1) = 4                                      ! points partition for //
     255      ig_paral(2) = klon_mpi_para_nb(mpi_rank)             ! nb of local cells
     256
     257      DO jf=1, klon_mpi_para_nb(mpi_rank)
     258        ig_paral(2+jf) = ind_cell_glo(jf)
     259      ENDDO
     260
     261    ELSE IF (grid_type==regular_lonlat) THEN
     262
     263      ALLOCATE( ig_paral(3) )
     264
     265      ig_paral(1) = 1                            ! apple partition for //
     266      ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1  ! offset
     267      ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1
     268
     269      IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
     270    ELSE
     271      abort_message='Pb : type of grid unknown'
     272      CALL abort_physic(modname,abort_message,1)
     273    ENDIF
     274
     275
    243276    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
    244277   
    … …  
    253286    ENDIF
    254287
    255     il_var_nodims(1) = 2
    256     il_var_nodims(2) = 1
    257 
    258     il_var_actual_shape(1) = 1
    259     il_var_actual_shape(2) = nbp_lon
    260     il_var_actual_shape(3) = 1
    261     il_var_actual_shape(4) = nbp_lat
     288    il_var_nodims(1) = 2                        ! rank of field array (1d or 2d)
     289    il_var_nodims(2) = 1                        ! always 1 in current oasis version" doc oasis3mct p18
     290
     291    il_var_actual_shape(1) = 1                  ! min of 1st dimension (always 1)
     292    il_var_actual_shape(2) = nbp_lon            ! max of 1st dimension
     293    il_var_actual_shape(3) = 1                  ! min of 2nd dimension (always 1)
     294    il_var_actual_shape(4) = nbp_lat            ! max of 2nd dimension
    262295   
    263296    il_var_type = PRISM_Real
    … …  
    302335! End definition
    303336!************************************************************************************
     337#ifdef CPP_XIOS
     338    CALL xios_oasis_enddef()
     339#endif
    304340    CALL prism_enddef_proto(ierror)
    305341    IF (ierror .NE. PRISM_Ok) THEN
    … …  
    311347
    312348#ifdef CPP_XIOS
    313     CALL wxios_context_init()
     349!    CALL wxios_context_init()
    314350#endif
    315351

  • LMDZ6/branches/Ocean_skin/libf/phylmd/orografi_strato.F90

    r2897 r3605  
    18191819  USE mod_phys_lmdz_para
    18201820  USE mod_grid_phy_lmdz
     1821  USE geometry_mod
    18211822  IMPLICIT NONE
    18221823
    … …  
    18321833  INTEGER jk
    18331834  REAL zpr, ztop, zsigt, zpm1r
    1834   REAL :: pplay_glo(klon_glo, nlev)
    1835   REAL :: paprs_glo(klon_glo, nlev+1)
     1835  INTEGER :: cell,ij,nstra_tmp,nktopg_tmp
     1836  REAL :: current_dist, dist_min,dist_min_glo
    18361837
    18371838  ! *       1.    SET THE VALUES OF THE PARAMETERS
    … …  
    18481849  ! old  ZSIGT=0.85
    18491850
    1850   CALL gather(pplay, pplay_glo)
    1851   CALL bcast(pplay_glo)
    1852   CALL gather(paprs, paprs_glo)
    1853   CALL bcast(paprs_glo)
    1854 
    1855   DO jk = 1, nlev
    1856     zpm1r = pplay_glo(klon_glo/2+1, jk)/paprs_glo(klon_glo/2+1, 1)
    1857     IF (zpm1r>=zsigt) THEN
    1858       nktopg = jk
    1859     END IF
    1860     zpm1r = pplay_glo(klon_glo/2+1, jk)/paprs_glo(klon_glo/2+1, 1)
    1861     IF (zpm1r>=ztop) THEN
    1862       nstra = jk
    1863     END IF
    1864   END DO
    1865 
     1851
     1852!ym Take the point at equator close to (0,0) coordinates.
     1853  dist_min=360
     1854  dist_min_glo=360.
     1855  cell=-1
     1856  DO ij=1,klon
     1857    current_dist=sqrt(longitude_deg(ij)**2+latitude_deg(ij)**2)
     1858    current_dist=current_dist*(1+(1e-10*ind_cell_glo(ij))/klon_glo) ! For point unicity
     1859    IF (dist_min>current_dist) THEN
     1860      dist_min=current_dist
     1861      cell=ij   
     1862    ENDIF 
     1863  ENDDO
     1864 
     1865  !PRINT *, 'SUGWD distmin cell=', dist_min,cell
     1866  CALL reduce_min(dist_min,dist_min_glo)
     1867  CALL bcast(dist_min_glo)
     1868  IF (dist_min/=dist_min_glo) cell=-1
     1869!ym in future find the point at equator close to (0,0) coordinates.
     1870  PRINT *, 'SUGWD distmin dist_min_glo cell=', dist_min,dist_min_glo,cell
     1871
     1872  nktopg_tmp=nktopg
     1873  nstra_tmp=nstra
     1874 
     1875  IF (cell/=-1) THEN
     1876
     1877    !print*,'SUGWD shape ',shape(pplay),cell+1
     1878
     1879    DO jk = 1, nlev
     1880      !zpm1r = pplay(cell+1, jk)/paprs(cell+1, 1)
     1881      zpm1r = pplay(cell, jk)/paprs(cell, 1)
     1882      IF (zpm1r>=zsigt) THEN
     1883        nktopg_tmp = jk
     1884      END IF
     1885      IF (zpm1r>=ztop) THEN
     1886        nstra_tmp = jk
     1887      END IF
     1888    END DO
     1889  ELSE
     1890    nktopg_tmp=0
     1891    nstra_tmp=0
     1892  ENDIF
     1893 
     1894  CALL reduce_sum(nktopg_tmp,nktopg)
     1895  CALL bcast(nktopg)
     1896  CALL reduce_sum(nstra_tmp,nstra)
     1897  CALL bcast(nstra)
     1898 
    18661899  ! inversion car dans orodrag on compte les niveaux a l'envers
    18671900  nktopg = nlev - nktopg + 1

  • LMDZ6/branches/Ocean_skin/libf/phylmd/pbl_surface_mod.F90

    r3458 r3605  
    6060    USE print_control_mod, ONLY: lunout
    6161    USE ioipsl_getin_p_mod, ONLY : getin_p
     62    IMPLICIT NONE
    6263
    6364    INCLUDE "dimsoil.h"
    … …  
    288289    USE indice_sol_mod
    289290    USE time_phylmdz_mod,   ONLY : day_ini,annee_ref,itau_phy
    290     USE mod_grid_phy_lmdz,  ONLY : nbp_lon, nbp_lat
     291    USE mod_grid_phy_lmdz,  ONLY : nbp_lon, nbp_lat, grid1dto2d_glo
    291292    USE print_control_mod,  ONLY : prt_level,lunout
    292293    USE ioipsl_getin_p_mod, ONLY : getin_p
    … …  
    861862          idayref = day_ini
    862863          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
    863           CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon,zx_lon)
     864          CALL grid1dTo2d_glo(rlon,zx_lon)
    864865          DO i = 1, nbp_lon
    865866             zx_lon(i,1) = rlon(i+1)
    866867             zx_lon(i,nbp_lat) = rlon(i+1)
    867868          ENDDO
    868           CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat,zx_lat)
     869          CALL grid1dTo2d_glo(rlat,zx_lat)
    869870          CALL histbeg("sous_index",nbp_lon,zx_lon(:,1),nbp_lat,zx_lat(1,:), &
    870871               1,nbp_lon,1,nbp_lat, &
    … …  
    19511952               itap, dtime, jour, knon, ni, &
    19521953!!jyg               ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
    1953                ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt1, yq1,&
     1954               ypplay(:,1), zgeo1(1:knon)/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&    ! ym missing init
    19541955               AcoefH, AcoefQ, BcoefH, BcoefQ, &
    19551956               AcoefU, AcoefV, BcoefU, BcoefV, &

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phyaqua_mod.F90

    • Property svn:keywords set to Id
    r3401 r3605  
     1!
     2! $Id$
     3!
    14MODULE phyaqua_mod
    25  ! Routines complementaires pour la physique planetaire.
    … …  
    58CONTAINS
    69
    7   SUBROUTINE iniaqua(nlon, iflag_phys)
     10  SUBROUTINE iniaqua(nlon,year_len,iflag_phys)
    811
    912    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    2932    USE indice_sol_mod
    3033    USE nrtype, ONLY: pi
    31     USE ioipsl
     34!    USE ioipsl
     35    USE mod_phys_lmdz_para, ONLY: is_master
     36    USE mod_phys_lmdz_transfert_para, ONLY: bcast
     37    USE mod_grid_phy_lmdz
     38    USE ioipsl_getin_p_mod, ONLY : getin_p
     39    USE phys_cal_mod , ONLY: calend, year_len_phy => year_len
    3240    IMPLICIT NONE
    3341
    … …  
    3644    include "dimsoil.h"
    3745
    38     INTEGER, INTENT (IN) :: nlon, iflag_phys
     46    INTEGER, INTENT (IN) :: nlon, year_len, iflag_phys
    3947    ! IM ajout latfi, lonfi
    4048!    REAL, INTENT (IN) :: lonfi(nlon), latfi(nlon)
    … …  
    5765    INTEGER it, unit, i, k, itap
    5866
    59     REAL airefi, zcufi, zcvfi
    60 
    6167    REAL rugos, albedo
    6268    REAL tsurf
    … …  
    6470    REAL qsol_f
    6571    REAL rugsrel(nlon)
    66     ! real zmea(nlon),zstd(nlon),zsig(nlon)
    67     ! real zgam(nlon),zthe(nlon),zpic(nlon),zval(nlon)
    68     ! real rlon(nlon),rlat(nlon)
    6972    LOGICAL alb_ocean
    70     ! integer demih_pas
    7173
    7274    CHARACTER *80 ans, file_forctl, file_fordat, file_start
    … …  
    7476    CHARACTER *2 cnbl
    7577
    76     REAL phy_nat(nlon, 360)
    77     REAL phy_alb(nlon, 360)
    78     REAL phy_sst(nlon, 360)
    79     REAL phy_bil(nlon, 360)
    80     REAL phy_rug(nlon, 360)
    81     REAL phy_ice(nlon, 360)
    82     REAL phy_fter(nlon, 360)
    83     REAL phy_foce(nlon, 360)
    84     REAL phy_fsic(nlon, 360)
    85     REAL phy_flic(nlon, 360)
     78    REAL phy_nat(nlon, year_len)
     79    REAL phy_alb(nlon, year_len)
     80    REAL phy_sst(nlon, year_len)
     81    REAL phy_bil(nlon, year_len)
     82    REAL phy_rug(nlon, year_len)
     83    REAL phy_ice(nlon, year_len)
     84    REAL phy_fter(nlon, year_len)
     85    REAL phy_foce(nlon, year_len)
     86    REAL phy_fsic(nlon, year_len)
     87    REAL phy_flic(nlon, year_len)
    8688
    8789    INTEGER, SAVE :: read_climoz = 0 ! read ozone climatology
    88 
    89     ! intermediate variables to use getin (need to be "save" to be shared by
    90     ! all threads)
    91     INTEGER, SAVE :: nbapp_rad_omp
    92     REAL, SAVE :: co2_ppm_omp, solaire_omp
    93     LOGICAL, SAVE :: alb_ocean_omp
    94     REAL, SAVE :: rugos_omp
     90!$OMP THREADPRIVATE(read_climoz)
     91
    9592    ! -------------------------------------------------------------------------
    9693    ! declaration pour l'appel a phyredem
    … …  
    117114    INTEGER l, ierr, aslun
    118115
    119 !    REAL longitude, latitude
    120116    REAL paire
    121117
    122 !    DATA latitude, longitude/48., 0./
     118    ! Local
     119    CHARACTER (LEN=20) :: modname='phyaqua'
     120    CHARACTER (LEN=80) :: abort_message
     121
    123122
    124123    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    130129    ! -------------------------------
    131130
     131    !IF (calend .EQ. "earth_360d") Then
     132      year_len_phy = year_len
     133    !END IF
     134   
     135    if (year_len.ne.360) then
     136      write (*,*) year_len
     137      write (*,*) 'iniaqua: 360 day calendar is required !'
     138      stop
     139    endif
    132140
    133141    type_aqua = iflag_phys/100
    … …  
    137145    IF (klon/=nlon) THEN
    138146      WRITE (*, *) 'iniaqua: klon=', klon, ' nlon=', nlon
    139       STOP 'probleme de dimensions dans iniaqua'
     147      abort_message= 'probleme de dimensions dans iniaqua'
     148      CALL abort_physic(modname,abort_message,1)
    140149    END IF
    141150    CALL phys_state_var_init(read_climoz)
    … …  
    148157    time = 0.
    149158
    150     ! IM ajout latfi, lonfi
    151 !    rlatd = latfi
    152 !    rlond = lonfi
    153 !    rlat = rlatd*180./pi
    154 !    rlon = rlond*180./pi
    155 
    156159    ! -----------------------------------------------------------------------
    157160    ! initialisations de la physique
    … …  
    160163    day_ini = day_ref
    161164    day_end = day_ini + ndays
    162 !    airefi = 1.
    163 !    zcufi = 1.
    164 !    zcvfi = 1.
    165     !$OMP MASTER
    166     nbapp_rad_omp = 24
    167     CALL getin('nbapp_rad', nbapp_rad_omp)
    168     !$OMP END MASTER
    169     !$OMP BARRIER
    170     nbapp_rad = nbapp_rad_omp
     165
     166    nbapp_rad = 24
     167    CALL getin_p('nbapp_rad', nbapp_rad)
    171168
    172169    ! ---------------------------------------------------------------------
    … …  
    175172    ! Initialisations des constantes
    176173    ! Ajouter les manquants dans planete.def... (albedo etc)
    177     !$OMP MASTER
    178     co2_ppm_omp = 348.
    179     CALL getin('co2_ppm', co2_ppm_omp)
    180     solaire_omp = 1365.
    181     CALL getin('solaire', solaire_omp)
     174    co2_ppm = 348.
     175    CALL getin_p('co2_ppm', co2_ppm)
     176
     177    solaire = 1365.
     178    CALL getin_p('solaire', solaire)
     179 
    182180    ! CALL getin('albedo',albedo) ! albedo is set below, depending on
    183181    ! type_aqua
    184     alb_ocean_omp = .TRUE.
    185     CALL getin('alb_ocean', alb_ocean_omp)
    186     !$OMP END MASTER
    187     !$OMP BARRIER
    188     co2_ppm = co2_ppm_omp
     182    alb_ocean = .TRUE.
     183    CALL getin_p('alb_ocean', alb_ocean)
     184
    189185    WRITE (*, *) 'iniaqua: co2_ppm=', co2_ppm
    190     solaire = solaire_omp
    191186    WRITE (*, *) 'iniaqua: solaire=', solaire
    192     alb_ocean = alb_ocean_omp
    193187    WRITE (*, *) 'iniaqua: alb_ocean=', alb_ocean
    194188
    … …  
    226220    END IF
    227221
    228     !$OMP MASTER
    229     rugos_omp = rugos
    230     CALL getin('rugos', rugos_omp)
    231     !$OMP END MASTER
    232     !$OMP BARRIER
    233     rugos = rugos_omp
     222    CALL getin_p('rugos', rugos)
     223
    234224    WRITE (*, *) 'iniaqua: rugos=', rugos
    235225    zmasq(:) = pctsrf(:, is_ter)
    … …  
    246236    ! endif !alb_ocean
    247237
    248     DO i = 1, 360
     238    DO i = 1, year_len
    249239      ! IM Terraplanete   phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
    250240      ! IM ajout calcul profil sst selon le cas considere (cf. FBr)
    … …  
    262252    CALL profil_sst(nlon, latitude, type_profil, phy_sst)
    263253
    264     CALL writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
    265       phy_fter, phy_foce, phy_flic, phy_fsic)
    266 
     254    IF (grid_type==unstructured) THEN
     255      CALL writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
     256                             phy_fter, phy_foce, phy_flic, phy_fsic)
     257    ELSE
     258     
     259       CALL writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
     260                     phy_fter, phy_foce, phy_flic, phy_fsic)
     261    ENDIF
    267262
    268263    ! ---------------------------------------------------------------------
    … …  
    339334    PRINT *, 'iniaqua: before phyredem'
    340335
    341     pbl_tke(:,:,:)=1.e-8
     336    pbl_tke(:,:,:) = 1.e-8
    342337    falb1 = albedo
    343338    falb2 = albedo
    … …  
    349344    wake_deltaq = 0.
    350345    wake_s = 0.
    351     wake_dens = 0. 
     346    wake_dens = 0.
    352347    wake_cstar = 0.
    353348    wake_pe = 0.
    … …  
    360355    alp_bl =0.
    361356    treedrg(:,:,:)=0.
     357
     358    u10m = 0.
     359    v10m = 0.
     360
     361    ql_ancien   = 0.
     362    qs_ancien   = 0.
     363    u_ancien    = 0.
     364    v_ancien    = 0.
     365    prw_ancien  = 0.
     366    prlw_ancien = 0.
     367    prsw_ancien = 0. 
     368
     369    ale_wake    = 0.
     370    ale_bl_stat = 0. 
     371
     372
     373!ym error : the sub surface dimension is the third not second : forgotten for iniaqua
     374!    falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
     375!    falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
     376    falb_dir(:,:,is_ter)=0.08; falb_dir(:,:,is_lic)=0.6
     377    falb_dir(:,:,is_oce)=0.5;  falb_dir(:,:,is_sic)=0.6
     378
     379!ym falb_dif has been forgotten, initialize with defaukt value found in phyetat0 or 0 ?
     380!ym probably the uninitialized value was 0 for standard (regular grid) case
     381    falb_dif(:,:,:)=0
    362382
    363383
    … …  
    488508  ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    489509
    490   SUBROUTINE writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
     510  SUBROUTINE writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
    491511      phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
    492512
    493     USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_omp_root
    494     USE mod_grid_phy_lmdz, ONLY: klon_glo
    495     USE mod_phys_lmdz_transfert_para, ONLY: gather
     513    USE mod_phys_lmdz_para, ONLY: is_omp_master, klon_mpi
     514    USE mod_phys_lmdz_transfert_para, ONLY: gather_omp
     515#ifdef CPP_XIOS
     516    USE xios
     517#endif
    496518    IMPLICIT NONE
     519
    497520    include "netcdf.inc"
    498521
    … …  
    509532    REAL, INTENT (IN) :: phy_fsic(klon, 360)
    510533
    511     REAL :: phy_glo(klon_glo, 360) ! temporary variable, to store phy_***(:)
     534    REAL :: phy_mpi(klon_mpi, 360) ! temporary variable, to store phy_***(:)
     535      ! on the whole physics grid
     536 
     537#ifdef CPP_XIOS
     538    PRINT *, 'writelim: Ecriture du fichier limit'
     539
     540    CALL gather_omp(phy_foce, phy_mpi)
     541    IF (is_omp_master) CALL xios_send_field('foce_limout',phy_mpi)
     542
     543    CALL gather_omp(phy_fsic, phy_mpi)
     544    IF (is_omp_master) CALL xios_send_field('fsic_limout',phy_mpi)
     545     
     546    CALL gather_omp(phy_fter, phy_mpi)
     547    IF (is_omp_master) CALL xios_send_field('fter_limout',phy_mpi)
     548     
     549    CALL gather_omp(phy_flic, phy_mpi)
     550    IF (is_omp_master) CALL xios_send_field('flic_limout',phy_mpi)
     551
     552    CALL gather_omp(phy_sst, phy_mpi)
     553    IF (is_omp_master) CALL xios_send_field('sst_limout',phy_mpi)
     554
     555    CALL gather_omp(phy_bil, phy_mpi)
     556    IF (is_omp_master) CALL xios_send_field('bils_limout',phy_mpi)
     557
     558    CALL gather_omp(phy_alb, phy_mpi)
     559    IF (is_omp_master) CALL xios_send_field('alb_limout',phy_mpi)
     560
     561    CALL gather_omp(phy_rug, phy_mpi)
     562    IF (is_omp_master) CALL xios_send_field('rug_limout',phy_mpi)
     563#endif
     564  END SUBROUTINE writelim_unstruct
     565
     566
     567
     568  SUBROUTINE writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
     569      phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
     570
     571    USE mod_phys_lmdz_para, ONLY: is_master
     572    USE mod_grid_phy_lmdz, ONLY: klon_glo
     573    USE mod_phys_lmdz_transfert_para, ONLY: gather
     574    USE phys_cal_mod, ONLY: year_len
     575    IMPLICIT NONE
     576    include "netcdf.inc"
     577
     578    INTEGER, INTENT (IN) :: klon
     579    REAL, INTENT (IN) :: phy_nat(klon, year_len)
     580    REAL, INTENT (IN) :: phy_alb(klon, year_len)
     581    REAL, INTENT (IN) :: phy_sst(klon, year_len)
     582    REAL, INTENT (IN) :: phy_bil(klon, year_len)
     583    REAL, INTENT (IN) :: phy_rug(klon, year_len)
     584    REAL, INTENT (IN) :: phy_ice(klon, year_len)
     585    REAL, INTENT (IN) :: phy_fter(klon, year_len)
     586    REAL, INTENT (IN) :: phy_foce(klon, year_len)
     587    REAL, INTENT (IN) :: phy_flic(klon, year_len)
     588    REAL, INTENT (IN) :: phy_fsic(klon, year_len)
     589
     590    REAL :: phy_glo(klon_glo, year_len) ! temporary variable, to store phy_***(:)
    512591      ! on the whole physics grid
    513592    INTEGER :: k
    … …  
    522601    INTEGER id_fter, id_foce, id_fsic, id_flic
    523602
    524     IF (is_mpi_root .AND. is_omp_root) THEN
     603    IF (is_master) THEN
    525604
    526605      PRINT *, 'writelim: Ecriture du fichier limit'
    … …  
    615694
    616695      ! write the 'times'
    617       DO k = 1, 360
     696      DO k = 1, year_len
    618697#ifdef NC_DOUBLE
    619698        ierr = nf_put_var1_double(nid, id_tim, k, dble(k))
    … …  
    627706      END DO
    628707
    629     END IF ! of if (is_mpi_root.and.is_omp_root)
     708    END IF ! of if (is_master)
    630709
    631710    ! write the fields, after having collected them on master
    632711
    633712    CALL gather(phy_nat, phy_glo)
    634     IF (is_mpi_root .AND. is_omp_root) THEN
     713    IF (is_master) THEN
    635714#ifdef NC_DOUBLE
    636715      ierr = nf_put_var_double(nid, id_nat, phy_glo)
    … …  
    645724
    646725    CALL gather(phy_sst, phy_glo)
    647     IF (is_mpi_root .AND. is_omp_root) THEN
     726    IF (is_master) THEN
    648727#ifdef NC_DOUBLE
    649728      ierr = nf_put_var_double(nid, id_sst, phy_glo)
    … …  
    658737
    659738    CALL gather(phy_bil, phy_glo)
    660     IF (is_mpi_root .AND. is_omp_root) THEN
     739    IF (is_master) THEN
    661740#ifdef NC_DOUBLE
    662741      ierr = nf_put_var_double(nid, id_bils, phy_glo)
    … …  
    671750
    672751    CALL gather(phy_alb, phy_glo)
    673     IF (is_mpi_root .AND. is_omp_root) THEN
     752    IF (is_master) THEN
    674753#ifdef NC_DOUBLE
    675754      ierr = nf_put_var_double(nid, id_alb, phy_glo)
    … …  
    684763
    685764    CALL gather(phy_rug, phy_glo)
    686     IF (is_mpi_root .AND. is_omp_root) THEN
     765    IF (is_master) THEN
    687766#ifdef NC_DOUBLE
    688767      ierr = nf_put_var_double(nid, id_rug, phy_glo)
    … …  
    697776
    698777    CALL gather(phy_fter, phy_glo)
    699     IF (is_mpi_root .AND. is_omp_root) THEN
     778    IF (is_master) THEN
    700779#ifdef NC_DOUBLE
    701780      ierr = nf_put_var_double(nid, id_fter, phy_glo)
    … …  
    710789
    711790    CALL gather(phy_foce, phy_glo)
    712     IF (is_mpi_root .AND. is_omp_root) THEN
     791    IF (is_master) THEN
    713792#ifdef NC_DOUBLE
    714793      ierr = nf_put_var_double(nid, id_foce, phy_glo)
    … …  
    723802
    724803    CALL gather(phy_fsic, phy_glo)
    725     IF (is_mpi_root .AND. is_omp_root) THEN
     804    IF (is_master) THEN
    726805#ifdef NC_DOUBLE
    727806      ierr = nf_put_var_double(nid, id_fsic, phy_glo)
    … …  
    736815
    737816    CALL gather(phy_flic, phy_glo)
    738     IF (is_mpi_root .AND. is_omp_root) THEN
     817    IF (is_master) THEN
    739818#ifdef NC_DOUBLE
    740819      ierr = nf_put_var_double(nid, id_flic, phy_glo)
    … …  
    749828
    750829    ! close file:
    751     IF (is_mpi_root .AND. is_omp_root) THEN
     830    IF (is_master) THEN
    752831      ierr = nf_close(nid)
    753832    END IF
    … …  
    759838  SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst)
    760839    USE dimphy
     840    USE phys_cal_mod , ONLY: year_len
    761841    IMPLICIT NONE
    762842
    763843    INTEGER nlon, type_profil, i, k, j
    764     REAL :: rlatd(nlon), phy_sst(nlon, 360)
     844    REAL :: rlatd(nlon), phy_sst(nlon, year_len)
    765845    INTEGER imn, imx, amn, amx, kmn, kmx
    766846    INTEGER p, pplus, nlat_max
    767847    PARAMETER (nlat_max=72)
    768848    REAL x_anom_sst(nlat_max)
    769 
    770     IF (klon/=nlon) STOP 'probleme de dimensions dans iniaqua'
     849    CHARACTER (LEN=20) :: modname='profil_sst'
     850    CHARACTER (LEN=80) :: abort_message
     851
     852    IF (klon/=nlon) THEN
     853       abort_message='probleme de dimensions dans profil_sst'
     854       CALL abort_physic(modname,abort_message,1)
     855    ENDIF
    771856    WRITE (*, *) ' profil_sst: type_profil=', type_profil
    772     DO i = 1, 360
     857    DO i = 1, year_len
    773858      ! phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
    774859
    … …  
    9631048    imx = 1
    9641049    kmx = 1
    965     DO k = 1, 360
     1050    DO k = 1, year_len
    9661051      DO i = 2, nlon
    9671052        IF (phy_sst(i,k)<amn) THEN

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phyetat0.F90

    r3458 r3605  
    99  USE pbl_surface_mod,  ONLY : pbl_surface_init
    1010  USE surface_data,     ONLY : type_ocean, version_ocean
    11   USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, dtime, &
     11  USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, phys_tstep, &
    1212       qsol, fevap, z0m, z0h, agesno, &
    1313       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
    … …  
    111111  IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
    112112     co2_ppm = tab_cntrl(3)
    113      RCO2    = co2_ppm * 1.0e-06  * 44.011/28.97
     113     RCO2    = co2_ppm * 1.0e-06 * RMCO2 / RMD
    114114     ! ELSE : keep value from .def
    115   END IF
    116 
    117   ! co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def)
    118   co2_ppm0   = tab_cntrl(16)
     115  ENDIF
     116
     117! co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def)
     118! co2_ppm0   = tab_cntrl(16)
     119! initial value for interactive CO2 run when there is no tracer field for CO2 in restart
     120  co2_ppm0=284.32
    119121
    120122  solaire_etat0      = tab_cntrl(4)
    … …  
    122124  tab_cntrl(6)=nbapp_rad
    123125
    124   if (iflag_cycle_diurne.GE.1) tab_cntrl( 7) = iflag_cycle_diurne
    125   if (soil_model) tab_cntrl( 8) =1.
    126   if (new_oliq) tab_cntrl( 9) =1.
    127   if (ok_orodr) tab_cntrl(10) =1.
    128   if (ok_orolf) tab_cntrl(11) =1.
    129   if (ok_limitvrai) tab_cntrl(12) =1.
     126  IF (iflag_cycle_diurne.GE.1) tab_cntrl( 7) = iflag_cycle_diurne
     127  IF (soil_model) tab_cntrl( 8) =1.
     128  IF (new_oliq) tab_cntrl( 9) =1.
     129  IF (ok_orodr) tab_cntrl(10) =1.
     130  IF (ok_orolf) tab_cntrl(11) =1.
     131  IF (ok_limitvrai) tab_cntrl(12) =1.
    130132
    131133  itau_phy = tab_cntrl(15)
    … …  
    164166  DO i=1,klon
    165167    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
    166       WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
    167                  " i=",i," lon_startphy(i)=",lon_startphy(i),&
    168                  " longitude_deg(i)=",longitude_deg(i)
    169       ! This is presumably serious enough to abort run
    170       CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
     168      IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i)))>=1) THEN
     169        WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
     170                   " i=",i," lon_startphy(i)=",lon_startphy(i),&
     171                   " longitude_deg(i)=",longitude_deg(i)
     172        ! This is presumably serious enough to abort run
     173        CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
     174      ENDIF
    171175    ENDIF
    172     IF (ABS(lon_startphy(i)-longitude_deg(i))>=0.0001) THEN
    173       WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
    174                  " i=",i," lon_startphy(i)=",lon_startphy(i),&
    175                  " longitude_deg(i)=",longitude_deg(i)
     176    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
     177      IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i))) > 0.0001) THEN
     178        WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
     179                   " i=",i," lon_startphy(i)=",lon_startphy(i),&
     180                   " longitude_deg(i)=",longitude_deg(i)
     181      ENDIF
    176182    ENDIF
    177183  ENDDO
    … …  
    223229        zmasq(i) = fractint(i)
    224230     ENDIF
    225   END DO
     231  ENDDO
    226232  fractint (1 : klon) =  pctsrf(1 : klon, is_oce)  &
    227233       + pctsrf(1 : klon, is_sic)
    … …  
    234240        zmasq(i) = 1. - fractint(i)
    235241     ENDIF
    236   END DO
     242  ENDDO
    237243
    238244!===================================================================
    … …  
    359365  !          dummy values (as is the case when generated by ce0l,
    360366  !          or by iniaqua)
    361   if ( (maxval(q_ancien).eq.minval(q_ancien))       .or. &
    362        (maxval(ql_ancien).eq.minval(ql_ancien))     .or. &
    363        (maxval(qs_ancien).eq.minval(qs_ancien))     .or. &
    364        (maxval(prw_ancien).eq.minval(prw_ancien))   .or. &
    365        (maxval(prlw_ancien).eq.minval(prlw_ancien)) .or. &
    366        (maxval(prsw_ancien).eq.minval(prsw_ancien)) .or. &
    367        (maxval(t_ancien).eq.minval(t_ancien)) ) then
     367  IF ( (maxval(q_ancien).EQ.minval(q_ancien))       .OR. &
     368       (maxval(ql_ancien).EQ.minval(ql_ancien))     .OR. &
     369       (maxval(qs_ancien).EQ.minval(qs_ancien))     .OR. &
     370       (maxval(prw_ancien).EQ.minval(prw_ancien))   .OR. &
     371       (maxval(prlw_ancien).EQ.minval(prlw_ancien)) .OR. &
     372       (maxval(prsw_ancien).EQ.minval(prsw_ancien)) .OR. &
     373       (maxval(t_ancien).EQ.minval(t_ancien)) ) THEN
    368374    ancien_ok=.false.
    369   endif
     375  ENDIF
    370376
    371377  found=phyetat0_get(klev,clwcon,"CLWCON","CLWCON",0.)
    … …  
    434440        found=phyetat0_get(1,trs(:,it),"trs_"//tname(iiq), &
    435441              "Surf trac"//tname(iiq),0.)
    436      END DO
     442     ENDDO
    437443     CALL traclmdz_from_restart(trs)
    438444  ENDIF
    … …  
    444450        IF (ierr /= 0) CALL abort_physic('phyetat0', 'pb allocation co2_send', 1)
    445451        found=phyetat0_get(1,co2_send,"co2_send","co2 send",co2_ppm)
    446      END IF
    447   END IF
     452     ENDIF
     453  ENDIF
    448454
    449455!===========================================
    … …  
    452458
    453459!  ondes de gravite non orographiques
    454   if (ok_gwd_rando) found = &
     460  IF (ok_gwd_rando) found = &
    455461       phyetat0_get(klev,du_gwd_rando,"du_gwd_rando","du_gwd_rando",0.)
    456   IF (.not. ok_hines .and. ok_gwd_rando) found &
     462  IF (.NOT. ok_hines .AND. ok_gwd_rando) found &
    457463       = phyetat0_get(klev,du_gwd_front,"du_gwd_front","du_gwd_front",0.)
    458464
    … …  
    473479
    474480  IF ( type_ocean == 'slab' ) THEN
    475       CALL ocean_slab_init(dtime, pctsrf)
     481      CALL ocean_slab_init(phys_tstep, pctsrf)
    476482      IF (nslay.EQ.1) THEN
    477483        found=phyetat0_get(1,tslab,"tslab01","tslab",0.)
    478484        IF (.NOT. found) THEN
    479485            found=phyetat0_get(1,tslab,"tslab","tslab",0.)
    480         END IF
     486        ENDIF
    481487      ELSE
    482488          DO i=1,nslay
    483489            WRITE(str2,'(i2.2)') i
    484490            found=phyetat0_get(1,tslab(:,i),"tslab"//str2,"tslab",0.) 
    485           END DO
    486       END IF
     491          ENDDO
     492      ENDIF
    487493      IF (.NOT. found) THEN
    488494          PRINT*, "phyetat0: Le champ <tslab> est absent"
    … …  
    490496          DO i=1,nslay
    491497              tslab(:,i)=MAX(ftsol(:,is_oce),271.35)
    492           END DO
    493       END IF
     498          ENDDO
     499      ENDIF
    494500
    495501      ! Sea ice variables
    … …  
    500506              PRINT*, "Initialisation a tsol_sic"
    501507                  tice(:)=ftsol(:,is_sic)
    502           END IF
     508          ENDIF
    503509          found=phyetat0_get(1,seaice,"seaice","seaice",0.)
    504510          IF (.NOT. found) THEN
    … …  
    508514              WHERE (pctsrf(:,is_sic).GT.EPSFRA)
    509515                  seaice=917.
    510               END WHERE
    511           END IF
    512       END IF !sea ice INT
    513   END IF ! Slab       
     516              ENDWHERE
     517          ENDIF
     518      ENDIF !sea ice INT
     519  ENDIF ! Slab       
    514520
    515521  ! on ferme le fichier
    … …  
    522528  ! Initialize module ocean_cpl_mod for the case of coupled ocean
    523529  IF ( type_ocean == 'couple' ) THEN
    524      CALL ocean_cpl_init(dtime, longitude_deg, latitude_deg)
    525   ENDIF
    526 
    527   CALL init_iophy_new(latitude_deg, longitude_deg)
     530     CALL ocean_cpl_init(phys_tstep, longitude_deg, latitude_deg)
     531  ENDIF
     532
     533!  CALL init_iophy_new(latitude_deg, longitude_deg)
    528534
    529535  ! Initilialize module fonte_neige_mod     

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phyredem.F90

    r3458 r3605  
    2929                                treedrg, ds_ns, dt_ns
    3030  USE geometry_mod, ONLY : longitude_deg, latitude_deg
    31   USE iostart, ONLY: open_restartphy, close_restartphy, put_field, put_var
     31  USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var
    3232  USE traclmdz_mod, ONLY : traclmdz_to_restart
    3333  USE infotrac_phy, ONLY: type_trac, niadv, tname, nbtr, nqo
    … …  
    6666  CHARACTER (len=2) :: str2
    6767  CHARACTER (len=256) :: nam, lnam
    68   INTEGER           :: it, iiq
     68  INTEGER           :: it, iiq, pass
    6969
    7070  !======================================================================
    … …  
    8181  CALL open_restartphy(fichnom)
    8282
     83 
    8384  DO ierr = 1, length
    8485     tab_cntrl(ierr) = 0.0
    … …  
    105106  tab_cntrl(16) = co2_ppm0
    106107
    107   CALL put_var("controle", "Parametres de controle", tab_cntrl)
    108 
    109   CALL put_field("longitude", &
    110        "Longitudes de la grille physique", longitude_deg)
    111 
    112   CALL put_field("latitude", "Latitudes de la grille physique", latitude_deg)
    113 
    114   ! PB ajout du masque terre/mer
    115 
    116   CALL put_field("masque", "masque terre mer", zmasq)
    117 
    118   ! BP ajout des fraction de chaque sous-surface
    119 
    120   ! Get last fractions from slab ocean
    121   IF (type_ocean == 'slab' .AND. version_ocean == "sicINT") THEN
    122       WHERE (1.-zmasq(:).GT.EPSFRA)
    123           pctsrf(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:))
    124           pctsrf(:,is_sic)=fsic(:)*(1.-zmasq(:))
    125       END WHERE
    126   END IF
    127 
    128   ! 1. fraction de terre
    129 
    130   CALL put_field("FTER", "fraction de continent", pctsrf(:, is_ter))
    131 
    132   ! 2. Fraction de glace de terre
    133 
    134   CALL put_field("FLIC", "fraction glace de terre", pctsrf(:, is_lic))
    135 
    136   ! 3. fraction ocean
    137 
    138   CALL put_field("FOCE", "fraction ocean", pctsrf(:, is_oce))
    139 
    140   ! 4. Fraction glace de mer
    141 
    142   CALL put_field("FSIC", "fraction glace mer", pctsrf(:, is_sic))
    143 
    144   IF(nbsrf>99) THEN
    145     PRINT*, "Trop de sous-mailles";  CALL abort_physic("phyredem", "", 1)
    146   END IF
    147   IF(nsoilmx>99) THEN
    148     PRINT*, "Trop de sous-surfaces"; CALL abort_physic("phyredem", "", 1)
    149   END IF
    150   IF(nsw>99) THEN
    151     PRINT*, "Trop de bandes"; CALL abort_physic("phyredem", "", 1)
    152   END IF
    153 
    154   CALL put_field_srf1("TS","Temperature",ftsol(:,:))
     108  DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
     109 
     110    CALL put_var(pass, "controle", "Parametres de controle", tab_cntrl)
     111
     112    CALL put_field(pass,"longitude", &
     113         "Longitudes de la grille physique", longitude_deg)
     114
     115    CALL put_field(pass,"latitude", "Latitudes de la grille physique", latitude_deg)
     116
     117    ! PB ajout du masque terre/mer
     118
     119    CALL put_field(pass,"masque", "masque terre mer", zmasq)
     120
     121    ! BP ajout des fraction de chaque sous-surface
     122
     123    ! Get last fractions from slab ocean
     124    IF (type_ocean == 'slab' .AND. version_ocean == "sicINT") THEN
     125        WHERE (1.-zmasq(:).GT.EPSFRA)
     126            pctsrf(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:))
     127            pctsrf(:,is_sic)=fsic(:)*(1.-zmasq(:))
     128        END WHERE
     129    END IF
     130
     131    ! 1. fraction de terre
     132
     133    CALL put_field(pass,"FTER", "fraction de continent", pctsrf(:, is_ter))
     134
     135    ! 2. Fraction de glace de terre
     136
     137    CALL put_field(pass,"FLIC", "fraction glace de terre", pctsrf(:, is_lic))
     138
     139    ! 3. fraction ocean
     140
     141    CALL put_field(pass,"FOCE", "fraction ocean", pctsrf(:, is_oce))
     142
     143    ! 4. Fraction glace de mer
     144
     145    CALL put_field(pass,"FSIC", "fraction glace mer", pctsrf(:, is_sic))
     146
     147    IF(nbsrf>99) THEN
     148      PRINT*, "Trop de sous-mailles";  CALL abort_physic("phyredem", "", 1)
     149    END IF
     150    IF(nsoilmx>99) THEN
     151      PRINT*, "Trop de sous-surfaces"; CALL abort_physic("phyredem", "", 1)
     152    END IF
     153    IF(nsw>99) THEN
     154      PRINT*, "Trop de bandes"; CALL abort_physic("phyredem", "", 1)
     155    END IF
     156
     157    CALL put_field_srf1(pass,"TS","Temperature",ftsol(:,:))
    155158
    156159! ================== Albedo =======================================
    157   print*,'PHYREDEM NOUVEAU'
    158   CALL put_field_srf2("A_dir_SW","Albedo direct",falb_dir(:,:,:))
    159   CALL put_field_srf2("A_dif_SW","Albedo diffus",falb_dif(:,:,:))
    160 
    161   CALL put_field_srf1("U10M", "u a 10m", u10m)
    162 
    163   CALL put_field_srf1("V10M", "v a 10m", v10m)
     160    print*,'PHYREDEM NOUVEAU'
     161    CALL put_field_srf2(pass,"A_dir_SW","Albedo direct",falb_dir(:,:,:))
     162    CALL put_field_srf2(pass,"A_dif_SW","Albedo diffus",falb_dif(:,:,:))
     163
     164    CALL put_field_srf1(pass,"U10M", "u a 10m", u10m)
     165
     166    CALL put_field_srf1(pass,"V10M", "v a 10m", v10m)
    164167
    165168
    166169! ================== Tsoil =========================================
    167   CALL put_field_srf2("Tsoil","Temperature",tsoil(:,:,:))
     170    CALL put_field_srf2(pass,"Tsoil","Temperature",tsoil(:,:,:))
    168171!FC
    169172!  CALL put_field_srf2("treedrg","freinage arbres",treedrg(:,:,:))
    170   CALL put_field("treedrg_ter","freinage arbres",treedrg(:,:,is_ter))
    171 
    172 
    173   CALL put_field_srf1("QS"  , "Humidite",qsurf(:,:))
    174 
    175   CALL put_field     ("QSOL", "Eau dans le sol (mm)", qsol)
    176 
    177   CALL put_field_srf1("EVAP", "Evaporation", fevap(:,:))
    178 
    179   CALL put_field_srf1("SNOW", "Neige", snow(:,:))
    180 
    181   CALL put_field("RADS", "Rayonnement net a la surface", radsol)
    182 
    183   CALL put_field("solsw", "Rayonnement solaire a la surface", solsw)
    184 
    185   CALL put_field("sollw", "Rayonnement IF a la surface", sollw)
    186 
    187   CALL put_field("sollwdown", "Rayonnement down IF a la surface", sollwdown)
    188 
    189   CALL put_field("fder", "Derive de flux", fder)
    190 
    191   CALL put_field("rain_f", "precipitation liquide", rain_fall)
    192 
    193   CALL put_field("snow_f", "precipitation solide", snow_fall)
    194 
    195   CALL put_field_srf1("Z0m", "rugosite", z0m(:,:))
    196 
    197   CALL put_field_srf1("Z0h", "rugosite", z0h(:,:))
    198 
    199   CALL put_field_srf1("AGESNO", "Age de la neige", agesno(:,:))
    200 
    201   CALL put_field("ZMEA", "ZMEA", zmea)
    202 
    203   CALL put_field("ZSTD", "ZSTD", zstd)
    204 
    205   CALL put_field("ZSIG", "ZSIG", zsig)
    206 
    207   CALL put_field("ZGAM", "ZGAM", zgam)
    208 
    209   CALL put_field("ZTHE", "ZTHE", zthe)
    210 
    211   CALL put_field("ZPIC", "ZPIC", zpic)
    212 
    213   CALL put_field("ZVAL", "ZVAL", zval)
    214 
    215   CALL put_field("RUGSREL", "RUGSREL", rugoro)
    216 
    217   CALL put_field("TANCIEN", "TANCIEN", t_ancien)
    218 
    219   CALL put_field("QANCIEN", "QANCIEN", q_ancien)
    220 
    221   CALL put_field("QLANCIEN", "QLANCIEN", ql_ancien)
    222 
    223   CALL put_field("QSANCIEN", "QSANCIEN", qs_ancien)
    224 
    225   CALL put_field("PRWANCIEN", "PRWANCIEN", prw_ancien)
    226 
    227   CALL put_field("PRLWANCIEN", "PRLWANCIEN", prlw_ancien)
    228 
    229   CALL put_field("PRSWANCIEN", "PRSWANCIEN", prsw_ancien)
    230 
    231   CALL put_field("UANCIEN", "UANCIEN", u_ancien)
    232 
    233   CALL put_field("VANCIEN", "VANCIEN", v_ancien)
    234 
    235   CALL put_field("CLWCON", "Eau liquide convective", clwcon)
    236 
    237   CALL put_field("RNEBCON", "Nebulosite convective", rnebcon)
    238 
    239   CALL put_field("RATQS", "Ratqs", ratqs)
    240 
    241   ! run_off_lic_0
    242 
    243   CALL put_field("RUNOFFLIC0", "Runofflic0", run_off_lic_0)
    244 
    245   ! DEB TKE PBL !
    246 
    247   IF (iflag_pbl>1) then
    248     CALL put_field_srf3("TKE", "Energ. Cineti. Turb.", &
    249          pbl_tke(:,:,:))
    250     CALL put_field_srf3("DELTATKE", "Del TKE wk/env.", &
    251          wake_delta_pbl_tke(:,:,:))
    252   END IF
    253 
    254   ! FIN TKE PBL !
    255   !IM ajout zmax0, f0, sig1, w01
    256   !IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
    257 
    258   CALL put_field("ZMAX0", "ZMAX0", zmax0)
    259 
    260   CALL put_field("F0", "F0", f0)
    261 
    262   CALL put_field("sig1", "sig1 Emanuel", sig1)
    263 
    264   CALL put_field("w01", "w01 Emanuel", w01)
    265 
    266   ! wake_deltat
    267   CALL put_field("WAKE_DELTAT", "WAKE_DELTAT", wake_deltat)
    268 
    269   CALL put_field("WAKE_DELTAQ", "WAKE_DELTAQ", wake_deltaq)
    270 
    271   CALL put_field("WAKE_S", "Wake frac. area", wake_s)
    272 
    273   CALL put_field("WAKE_DENS", "Wake num. /unit area", wake_dens)
    274 
    275   CALL put_field("WAKE_CSTAR", "WAKE_CSTAR", wake_cstar)
    276 
    277   CALL put_field("WAKE_PE", "WAKE_PE", wake_pe)
    278 
    279   CALL put_field("WAKE_FIP", "WAKE_FIP", wake_fip)
    280 
    281   ! thermiques
    282 
    283   CALL put_field("FM_THERM", "FM_THERM", fm_therm)
    284 
    285   CALL put_field("ENTR_THERM", "ENTR_THERM", entr_therm)
    286 
    287   CALL put_field("DETR_THERM", "DETR_THERM", detr_therm)
    288 
    289   CALL put_field("ALE_BL", "ALE_BL", ale_bl)
    290 
    291   CALL put_field("ALE_BL_TRIG", "ALE_BL_TRIG", ale_bl_trig)
    292 
    293   CALL put_field("ALP_BL", "ALP_BL", alp_bl)
    294 
    295   CALL put_field("ALE_WAKE", "ALE_WAKE", ale_wake)
    296 
    297   CALL put_field("ALE_BL_STAT", "ALE_BL_STAT", ale_bl_stat)
    298 
    299 
    300   ! trs from traclmdz_mod
    301   IF (type_trac == 'lmdz') THEN
    302      CALL traclmdz_to_restart(trs)
    303      DO it=1, nbtr
     173    CALL put_field(pass,"treedrg_ter","freinage arbres",treedrg(:,:,is_ter))
     174
     175
     176    CALL put_field_srf1(pass,"QS"  , "Humidite",qsurf(:,:))
     177
     178    CALL put_field     (pass,"QSOL", "Eau dans le sol (mm)", qsol)
     179
     180    CALL put_field_srf1(pass,"EVAP", "Evaporation", fevap(:,:))
     181
     182    CALL put_field_srf1(pass,"SNOW", "Neige", snow(:,:))
     183
     184    CALL put_field(pass,"RADS", "Rayonnement net a la surface", radsol)
     185
     186    CALL put_field(pass,"solsw", "Rayonnement solaire a la surface", solsw)
     187
     188    CALL put_field(pass,"sollw", "Rayonnement IF a la surface", sollw)
     189
     190    CALL put_field(pass,"sollwdown", "Rayonnement down IF a la surface", sollwdown)
     191
     192    CALL put_field(pass,"fder", "Derive de flux", fder)
     193
     194    CALL put_field(pass,"rain_f", "precipitation liquide", rain_fall)
     195
     196    CALL put_field(pass,"snow_f", "precipitation solide", snow_fall)
     197
     198    CALL put_field_srf1(pass,"Z0m", "rugosite", z0m(:,:))
     199
     200    CALL put_field_srf1(pass,"Z0h", "rugosite", z0h(:,:))
     201
     202    CALL put_field_srf1(pass,"AGESNO", "Age de la neige", agesno(:,:))
     203
     204    CALL put_field(pass,"ZMEA", "ZMEA", zmea)
     205
     206    CALL put_field(pass,"ZSTD", "ZSTD", zstd)
     207
     208    CALL put_field(pass,"ZSIG", "ZSIG", zsig)
     209
     210    CALL put_field(pass,"ZGAM", "ZGAM", zgam)
     211
     212    CALL put_field(pass,"ZTHE", "ZTHE", zthe)
     213
     214    CALL put_field(pass,"ZPIC", "ZPIC", zpic)
     215
     216    CALL put_field(pass,"ZVAL", "ZVAL", zval)
     217
     218    CALL put_field(pass,"RUGSREL", "RUGSREL", rugoro)
     219
     220    CALL put_field(pass,"TANCIEN", "TANCIEN", t_ancien)
     221
     222    CALL put_field(pass,"QANCIEN", "QANCIEN", q_ancien)
     223
     224    CALL put_field(pass,"QLANCIEN", "QLANCIEN", ql_ancien)
     225
     226    CALL put_field(pass,"QSANCIEN", "QSANCIEN", qs_ancien)
     227
     228    CALL put_field(pass,"PRWANCIEN", "PRWANCIEN", prw_ancien)
     229
     230    CALL put_field(pass,"PRLWANCIEN", "PRLWANCIEN", prlw_ancien)
     231
     232    CALL put_field(pass,"PRSWANCIEN", "PRSWANCIEN", prsw_ancien)
     233
     234    CALL put_field(pass,"UANCIEN", "UANCIEN", u_ancien)
     235
     236    CALL put_field(pass,"VANCIEN", "VANCIEN", v_ancien)
     237
     238    CALL put_field(pass,"CLWCON", "Eau liquide convective", clwcon)
     239
     240    CALL put_field(pass,"RNEBCON", "Nebulosite convective", rnebcon)
     241
     242    CALL put_field(pass,"RATQS", "Ratqs", ratqs)
     243
     244    ! run_off_lic_0
     245
     246    CALL put_field(pass,"RUNOFFLIC0", "Runofflic0", run_off_lic_0)
     247
     248    ! DEB TKE PBL !
     249
     250    IF (iflag_pbl>1) then
     251      CALL put_field_srf3(pass,"TKE", "Energ. Cineti. Turb.", &
     252           pbl_tke(:,:,:))
     253      CALL put_field_srf3(pass,"DELTATKE", "Del TKE wk/env.", &
     254           wake_delta_pbl_tke(:,:,:))
     255    END IF
     256
     257    ! FIN TKE PBL !
     258    !IM ajout zmax0, f0, sig1, w01
     259    !IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
     260
     261    CALL put_field(pass,"ZMAX0", "ZMAX0", zmax0)
     262
     263    CALL put_field(pass,"F0", "F0", f0)
     264
     265    CALL put_field(pass,"sig1", "sig1 Emanuel", sig1)
     266
     267    CALL put_field(pass,"w01", "w01 Emanuel", w01)
     268
     269    ! wake_deltat
     270    CALL put_field(pass,"WAKE_DELTAT", "WAKE_DELTAT", wake_deltat)
     271
     272    CALL put_field(pass,"WAKE_DELTAQ", "WAKE_DELTAQ", wake_deltaq)
     273
     274    CALL put_field(pass,"WAKE_S", "Wake frac. area", wake_s)
     275
     276    CALL put_field(pass,"WAKE_DENS", "Wake num. /unit area", wake_dens)
     277
     278    CALL put_field(pass,"WAKE_CSTAR", "WAKE_CSTAR", wake_cstar)
     279
     280    CALL put_field(pass,"WAKE_PE", "WAKE_PE", wake_pe)
     281
     282    CALL put_field(pass,"WAKE_FIP", "WAKE_FIP", wake_fip)
     283
     284    ! thermiques
     285
     286    CALL put_field(pass,"FM_THERM", "FM_THERM", fm_therm)
     287
     288    CALL put_field(pass,"ENTR_THERM", "ENTR_THERM", entr_therm)
     289
     290    CALL put_field(pass,"DETR_THERM", "DETR_THERM", detr_therm)
     291
     292    CALL put_field(pass,"ALE_BL", "ALE_BL", ale_bl)
     293
     294    CALL put_field(pass,"ALE_BL_TRIG", "ALE_BL_TRIG", ale_bl_trig)
     295
     296    CALL put_field(pass,"ALP_BL", "ALP_BL", alp_bl)
     297
     298    CALL put_field(pass,"ALE_WAKE", "ALE_WAKE", ale_wake)
     299
     300    CALL put_field(pass,"ALE_BL_STAT", "ALE_BL_STAT", ale_bl_stat)
     301
     302
     303    ! trs from traclmdz_mod
     304    IF (type_trac == 'lmdz') THEN
     305       CALL traclmdz_to_restart(trs)
     306       DO it=1, nbtr
    304307!!        iiq=niadv(it+2)                                                           ! jyg
    305         iiq=niadv(it+nqo)                                                           ! jyg
    306         CALL put_field("trs_"//tname(iiq), "", trs(:, it))
    307      END DO
    308      IF (carbon_cycle_cpl) THEN
    309         IF (.NOT. ALLOCATED(co2_send)) THEN
    310            ! This is the case of create_etat0_limit, ce0l
    311            ALLOCATE(co2_send(klon))
    312            co2_send(:) = co2_ppm0
     308          iiq=niadv(it+nqo)                                                           ! jyg
     309          CALL put_field(pass,"trs_"//tname(iiq), "", trs(:, it))
     310       END DO
     311       IF (carbon_cycle_cpl) THEN
     312          IF (.NOT. ALLOCATED(co2_send)) THEN
     313             ! This is the case of create_etat0_limit, ce0l
     314             ALLOCATE(co2_send(klon))
     315             co2_send(:) = co2_ppm0
     316          END IF
     317          CALL put_field(pass,"co2_send", "co2_ppm for coupling", co2_send)
     318       END IF
     319    END IF
     320
     321    ! Restart variables for Slab ocean
     322    IF (type_ocean == 'slab') THEN
     323        IF (nslay.EQ.1) THEN
     324          CALL put_field(pass,"tslab", "Slab ocean temperature", tslab)
     325        ELSE
     326          DO it=1,nslay
     327            WRITE(str2,'(i2.2)') it
     328            CALL put_field(pass,"tslab"//str2, "Slab ocean temperature", tslab(:,it))
     329          END DO
    313330        END IF
    314         CALL put_field("co2_send", "co2_ppm for coupling", co2_send)
    315      END IF
    316   END IF
    317 
    318   ! Restart variables for Slab ocean
    319   IF (type_ocean == 'slab') THEN
    320       IF (nslay.EQ.1) THEN
    321         CALL put_field("tslab", "Slab ocean temperature", tslab)
    322       ELSE
    323         DO it=1,nslay
    324           WRITE(str2,'(i2.2)') it
    325           CALL put_field("tslab"//str2, "Slab ocean temperature", tslab(:,it))
    326         END DO
    327       END IF
    328       IF (version_ocean == 'sicINT') THEN
    329           CALL put_field("seaice", "Slab seaice (kg/m2)", seaice)
    330           CALL put_field("slab_tice", "Slab sea ice temperature", tice)
    331       END IF
    332   END IF
    333 
    334   if (ok_gwd_rando) call put_field("du_gwd_rando", &
    335        "tendency on zonal wind due to flott gravity waves", du_gwd_rando)
    336 
    337   IF (.not. ok_hines .and. ok_gwd_rando) call put_field("du_gwd_front", &
    338        "tendency on zonal wind due to acama gravity waves", du_gwd_front)
    339 
    340   if (activate_ocean_skin >= 1) then
    341      CALL put_field("ds_ns", "delta salinity near surface", ds_ns)
    342      CALL put_field("dT_ns", "delta temperature near surface", dT_ns)
    343   end if
     331        IF (version_ocean == 'sicINT') THEN
     332            CALL put_field(pass,"seaice", "Slab seaice (kg/m2)", seaice)
     333            CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice)
     334        END IF
     335    END IF
     336
     337    if (ok_gwd_rando) call put_field(pass,"du_gwd_rando", &
     338         "tendency on zonal wind due to flott gravity waves", du_gwd_rando)
     339
     340    IF (.not. ok_hines .and. ok_gwd_rando) call put_field(pass,"du_gwd_front", &
     341         "tendency on zonal wind due to acama gravity waves", du_gwd_front)
     342
     343    if (activate_ocean_skin >= 1) then
     344       CALL put_field(pass, "ds_ns", "delta salinity near surface", ds_ns)
     345       CALL put_field(pass, "dT_ns", "delta temperature near surface", dT_ns)
     346    end if
     347   
     348    IF (pass==1) CALL enddef_restartphy
     349    IF (pass==2) CALL close_restartphy
     350 ENDDO
    344351 
    345   CALL close_restartphy
    346352  !$OMP BARRIER
    347353
    … …  
    350356
    351357
    352 SUBROUTINE put_field_srf1(nam,lnam,field)
     358SUBROUTINE put_field_srf1(pass,nam,lnam,field)
    353359
    354360  IMPLICIT NONE
     361  INTEGER, INTENT(IN)            :: pass
    355362  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
    356363  REAL,              INTENT(IN) :: field(:,:)
    … …  
    360367    nm=TRIM(nam)//TRIM(str)
    361368    lm=TRIM(lnam)//" de surface No. "//TRIM(str)
    362     CALL put_field(nm,lm,field(:,nsrf))
     369    CALL put_field(pass,nm,lm,field(:,nsrf))
    363370  END DO
    364371
    … …  
    366373
    367374
    368 SUBROUTINE put_field_srf2(nam,lnam,field)
     375SUBROUTINE put_field_srf2(pass,nam,lnam,field)
    369376
    370377  IMPLICIT NONE
     378  INTEGER, INTENT(IN)            :: pass
    371379  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
    372380  REAL,              INTENT(IN) :: field(:,:,:)
    … …  
    378386      nm=TRIM(nam)//TRIM(str)
    379387      lm=TRIM(lnam)//" du sol No. "//TRIM(str)
    380       CALL put_field(nm,lm,field(:,isoil,nsrf))
     388      CALL put_field(pass,nm,lm,field(:,isoil,nsrf))
    381389    END DO
    382390  END DO
    … …  
    385393
    386394
    387 SUBROUTINE put_field_srf3(nam,lnam,field)
     395SUBROUTINE put_field_srf3(pass,nam,lnam,field)
    388396
    389397  IMPLICIT NONE
     398  INTEGER, INTENT(IN)            :: pass
    390399  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
    391400  REAL,              INTENT(IN) :: field(:,:,:)
    … …  
    395404    nm=TRIM(nam)//TRIM(str)
    396405    lm=TRIM(lnam)//TRIM(str)
    397     CALL put_field(nm,lm,field(:,1:klev+1,nsrf))
     406    CALL put_field(pass,nm,lm,field(:,1:klev+1,nsrf))
    398407  END DO
    399408

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phys_cal_mod.F90

    • Property svn:keywords set to Id
    r2802 r3605  
    1 ! $Id:$
     1! $Id$
    22MODULE phys_cal_mod
    33! This module contains information on the calendar at the current time step
    … …  
    3737  SUBROUTINE phys_cal_init(annee_ref,day_ref)
    3838
    39     USE IOIPSL, ONLY:  ymds2ju
     39    USE IOIPSL, ONLY:  ymds2ju, ioconf_calendar
     40    USE mod_phys_lmdz_para, ONLY:  is_master,is_omp_master
    4041    USE ioipsl_getin_p_mod, ONLY: getin_p
    4142
    … …  
    4748    calend = 'earth_360d' ! default
    4849    CALL getin_p("calend",calend)
     50
     51    IF (is_omp_master) THEN
     52      IF (calend == 'earth_360d') THEN
     53        CALL ioconf_calendar('360d')
     54      ELSE IF (calend == 'earth_365d') THEN
     55        CALL ioconf_calendar('noleap')
     56      ELSE IF (calend == 'earth_366d' .OR. calend == 'gregorian') THEN
     57        CALL ioconf_calendar('gregorian')
     58      ELSE
     59        CALL abort_physic('phys_cal_init','Mauvais choix de calendrier',1)
     60      ENDIF
     61    ENDIF
     62!$OMP BARRIER
    4963     
    5064    CALL ymds2ju(annee_ref, 1, day_ref, 0., jD_ref)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phys_local_var_mod.F90

    r3379 r3605  
    343343!$OMP THREADPRIVATE(zxfluxlat_x, zxfluxlat_w)
    344344!jyg<
    345 !!! Entr\E9es suppl\E9mentaires couche-limite
     345!!! Entrees supplementaires couche-limite
    346346!!      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: t_x, t_w
    347347!!!$OMP THREADPRIVATE(t_x, t_w)
    … …  
    349349!!!$OMP THREADPRIVATE(q_x, q_w)
    350350!>jyg
    351 ! Variables suppl\E9mentaires dans physiq.F relative au splitting de la surface
     351!!! Sorties ferret
     352      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: dtvdf_x, dtvdf_w
     353!$OMP THREADPRIVATE(dtvdf_x, dtvdf_w)
     354      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: dqvdf_x, dqvdf_w
     355!$OMP THREADPRIVATE(dqvdf_x, dqvdf_w)
     356! Variables supplementaires dans physiq.F relative au splitting de la surface
    352357      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: pbl_tke_input
    353358!$OMP THREADPRIVATE(pbl_tke_input)
    … …  
    375380      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_min_mon, t2m_max_mon
    376381!$OMP THREADPRIVATE(t2m_min_mon, t2m_max_mon)
     382      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zq2m_cor, zt2m_cor
     383!$OMP THREADPRIVATE(zq2m_cor, zt2m_cor)
     384      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zu10m_cor, zv10m_cor
     385!$OMP THREADPRIVATE(zu10m_cor, zv10m_cor)
     386      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zrh2m_cor, zqsat2m_cor
     387!$OMP THREADPRIVATE(zrh2m_cor, zqsat2m_cor)
    377388      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: weak_inversion
    378389!$OMP THREADPRIVATE(weak_inversion)
    … …  
    405416      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: pmflxr, pmflxs
    406417!$OMP THREADPRIVATE(pmflxr, pmflxs)
    407       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: wdtrainA, wdtrainM
    408 !$OMP THREADPRIVATE(wdtrainA, wdtrainM)
     418      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: wdtrainA, wdtrainS, wdtrainM
     419!$OMP THREADPRIVATE(wdtrainA, wdtrainS, wdtrainM)
    409420      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: da, mp
    410421!$OMP THREADPRIVATE(da, mp)
    … …  
    417428      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: ev
    418429!$OMP THREADPRIVATE(ev)
     430      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: qtaa
     431!$OMP THREADPRIVATE(qtaa)
    419432      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: clw
    420433!$OMP THREADPRIVATE(clw)
    … …  
    578591      ALLOCATE(plul_st(klon),plul_th(klon))
    579592      ALLOCATE(d_t_vdf(klon,klev),d_q_vdf(klon,klev),d_t_diss(klon,klev))
     593
     594      ALLOCATE(d_t_vdf_w(klon,klev),d_q_vdf_w(klon,klev))
     595      ALLOCATE(d_t_vdf_x(klon,klev),d_q_vdf_x(klon,klev))
     596
    580597      ALLOCATE(d_u_vdf(klon,klev),d_v_vdf(klon,klev))
    581598      ALLOCATE(d_t_oli(klon,klev),d_t_oro(klon,klev))
    … …  
    589606! Special RRTM
    590607      ALLOCATE(ZLWFT0_i(klon,klev+1),ZSWFT0_i(klon,klev+1),ZFLDN0(klon,klev+1))
     608      ZFLDN0= 0.
    591609      ALLOCATE(ZFLUP0(klon,klev+1),ZFSDN0(klon,klev+1),ZFSUP0(klon,klev+1))
    592610!
    … …  
    603621      ALLOCATE(dv_gwd_rando(klon,klev),dv_gwd_front(klon,klev))
    604622      ALLOCATE(east_gwstress(klon,klev),west_gwstress(klon,klev))
     623      east_gwstress(:,:)=0 !ym missing init
     624      west_gwstress(:,:)=0 !ym missing init
    605625      ALLOCATE(d_t_hin(klon,klev))
    606626      ALLOCATE(d_q_ch4(klon,klev))
    … …  
    627647      ALLOCATE(od865aer(klon))
    628648      ALLOCATE(dryod550aer(klon))
     649      dryod550aer(:) = 0.
    629650      ALLOCATE(abs550aer(klon))
     651      abs550aer(:) = 0.
    630652      ALLOCATE(ec550aer(klon,klev))
    631653      ALLOCATE(od550lt1aer(klon))
    … …  
    672694      ALLOCATE(toplwad0_aerop(klon), sollwad0_aerop(klon))
    673695
    674 ! FH Ajout de celles n??cessaires au phys_output_write_mod
     696! FH Ajout de celles necessaires au phys_output_write_mod
    675697
    676698      ALLOCATE(tal1(klon), pal1(klon), pab1(klon), pab2(klon))
    … …  
    721743!!      ALLOCATE(q_x(klon,klev), q_w(klon,klev))
    722744!>jyg
    723       ALLOCATE(d_t_vdf_x(klon,klev), d_t_vdf_w(klon,klev))
    724       ALLOCATE(d_q_vdf_x(klon,klev), d_q_vdf_w(klon,klev))
     745      ALLOCATE(dtvdf_x(klon,klev), dtvdf_w(klon,klev))
     746      dtvdf_x = 0 ; dtvdf_w=0 ;   !ym missing init
     747      ALLOCATE(dqvdf_x(klon,klev), dqvdf_w(klon,klev))
     748      dqvdf_x = 0 ; dqvdf_w=0 ;   !ym missing init
    725749      ALLOCATE(pbl_tke_input(klon,klev+1,nbsrf))
    726750      ALLOCATE(t_therm(klon,klev), q_therm(klon,klev),u_therm(klon,klev), v_therm(klon,klev))
    … …  
    736760      ALLOCATE(zt2m_min_mon(klon), zt2m_max_mon(klon))
    737761      ALLOCATE(t2m_min_mon(klon), t2m_max_mon(klon))
     762      ALLOCATE(zq2m_cor(klon), zt2m_cor(klon), zu10m_cor(klon), zv10m_cor(klon))
     763      ALLOCATE(zrh2m_cor(klon), zqsat2m_cor(klon))
    738764      ALLOCATE(sens(klon), flwp(klon), fiwp(klon))
    739765      ALLOCATE(alp_bl_conv(klon), alp_bl_det(klon))
     766      alp_bl_conv(:)=0 ;  alp_bl_det(:)=0
    740767      ALLOCATE(alp_bl_fluct_m(klon), alp_bl_fluct_tke(klon))
     768      alp_bl_fluct_m(:)=0 ; alp_bl_fluct_tke(:)= 0.
    741769      ALLOCATE(alp_bl_stat(klon), n2(klon), s2(klon))
     770      alp_bl_stat(:)=0
    742771      ALLOCATE(proba_notrig(klon), random_notrig(klon))
    743772      ALLOCATE(cv_gen(klon))
    … …  
    764793!  Deep convective variables used in phytrac
    765794      ALLOCATE(pmflxr(klon, klev+1), pmflxs(klon, klev+1))
    766       ALLOCATE(wdtrainA(klon,klev),wdtrainM(klon,klev))
     795      ALLOCATE(wdtrainA(klon,klev),wdtrainS(klon,klev),wdtrainM(klon,klev))
    767796      ALLOCATE(dnwd(klon, klev), upwd(klon, klev) )
    768797      ALLOCATE(ep(klon,klev))                          ! epmax_cape
    … …  
    774803      ALLOCATE(ev(klon,klev) )
    775804      ALLOCATE(elij(klon,klev,klev) )
     805      ALLOCATE(qtaa(klon,klev) )
    776806      ALLOCATE(clw(klon,klev) )
    777807      ALLOCATE(epmlmMm(klon,klev,klev), eplaMm(klon,klev) )
    … …  
    968998      DEALLOCATE(toplwad0_aerop, sollwad0_aerop)
    969999
    970 ! FH Ajout de celles n??cessaires au phys_output_write_mod
     1000! FH Ajout de celles necessaires au phys_output_write_mod
    9711001      DEALLOCATE(tal1, pal1, pab1, pab2)
    9721002      DEALLOCATE(ptstar, pt0, slp)
    … …  
    10271057      DEALLOCATE(zt2m_min_mon, zt2m_max_mon)
    10281058      DEALLOCATE(t2m_min_mon, t2m_max_mon)
     1059      DEALLOCATE(zq2m_cor, zt2m_cor, zu10m_cor, zv10m_cor)
     1060      DEALLOCATE(zrh2m_cor, zqsat2m_cor)
    10291061      DEALLOCATE(sens, flwp, fiwp)
    10301062      DEALLOCATE(alp_bl_conv,alp_bl_det)
    … …  
    10531085
    10541086      DEALLOCATE(pmflxr, pmflxs)
    1055       DEALLOCATE(wdtrainA, wdtrainM)
     1087      DEALLOCATE(wdtrainA, wdtrainS, wdtrainM)
    10561088      DEALLOCATE(upwd, dnwd)
    10571089      DEALLOCATE(ep)
    … …  
    10631095      DEALLOCATE(ev )
    10641096      DEALLOCATE(elij )
     1097      DEALLOCATE(qtaa )
    10651098      DEALLOCATE(clw )
    10661099      DEALLOCATE(epmlmMm, eplaMm )

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phys_output_ctrlout_mod.F90

    r3601 r3605  
    77  USE indice_sol_mod
    88  USE aero_mod
    9 
    10 
    119
    1210  IMPLICIT NONE
    … …  
    2624    'io_lat', '', '', (/ ('once', i=1, 10) /))
    2725
    28 !!! Comosantes de la coordonnee sigma-hybride
     26!!! Composantes de la coordonnee sigma-hybride
    2927!!! Ap et Bp et interfaces
    3028  TYPE(ctrl_out), SAVE :: o_Ahyb = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
    31     'Ahyb', '', '', (/ ('once', i=1, 10) /))
     29    'Ahyb', 'Ahyb at level interface', '', (/ ('once', i=1, 10) /))
    3230  TYPE(ctrl_out), SAVE :: o_Bhyb = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
    33     'Bhyb', '', '', (/ ('once', i=1, 10) /))
    34   TYPE(ctrl_out), SAVE :: o_Ahyb_inter = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
    35     'Ahyb_inter', '', '', (/ ('once', i=1, 10) /))
    36   TYPE(ctrl_out), SAVE :: o_Bhyb_inter = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
    37     'Bhyb_inter', '', '', (/ ('once', i=1, 10) /))
     31    'Bhyb', 'Bhyb at level interface', '', (/ ('once', i=1, 10) /))
     32  TYPE(ctrl_out), SAVE :: o_Ahyb_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
     33    'Ahyb_bounds', '', '', (/ ('once', i=1, 10) /))
     34  TYPE(ctrl_out), SAVE :: o_Bhyb_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
     35    'Bhyb_bounds', '', '', (/ ('once', i=1, 10) /))
     36!!! Composantes de la coordonnee sigma-hybride  au milieu des couches
     37!!! Aps et Bps et interfaces
     38  TYPE(ctrl_out), SAVE :: o_Ahyb_mid = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
     39    'Ahyb_mid', 'Ahyb at the middle of the level', '', (/ ('once', i=1, 10) /))
     40  TYPE(ctrl_out), SAVE :: o_Bhyb_mid = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
     41    'Bhyb_mid', 'Bhyb at the middle of the level', '', (/ ('once', i=1, 10) /))
     42  TYPE(ctrl_out), SAVE :: o_Ahyb_mid_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
     43    'Ahyb_mid_bounds', '', '', (/ ('once', i=1, 10) /))
     44  TYPE(ctrl_out), SAVE :: o_Bhyb_mid_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
     45    'Bhyb_mid_bounds', '', '', (/ ('once', i=1, 10) /))
     46
    3847  TYPE(ctrl_out), SAVE :: o_Alt = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), &
    3948    'Alt', '', '', (/ ('', i=1, 10) /))
    … …  
    10181027!FC
    10191028
    1020 
    10211029  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_l_mixmin      = (/             &
    10221030      ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/),'l_mixmin_ter',       &
    … …  
    12841292!--end add ThL
    12851293
     1294!---CO2 fluxes for interactive CO2 configuration
     1295  TYPE(ctrl_out), SAVE :: o_flx_co2_ff = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
     1296    'flx_co2_ff', 'CO2 flux from fossil fuel and cement', '1', (/ ('', i=1, 10) /))
     1297  TYPE(ctrl_out), SAVE :: o_flx_co2_bb = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
     1298    'flx_co2_bb', 'CO2 flux from biomass burning', '1', (/ ('', i=1, 10) /))
     1299  TYPE(ctrl_out), SAVE :: o_flx_co2_ocean = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
     1300    'flx_co2_ocean', 'CO2 flux from the ocean', '1', (/ ('', i=1, 10) /))
     1301  TYPE(ctrl_out), SAVE :: o_flx_co2_land = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
     1302    'flx_co2_land', 'CO2 flux from the land', '1', (/ ('', i=1, 10) /))
     1303
    12861304#ifdef CPP_StratAer
    12871305!--extinction coefficient
    … …  
    12921310!--strat aerosol optical depth
    12931311  TYPE(ctrl_out), SAVE :: o_tau_strat_550 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
    1294     'od550_strat_only', 'Stratospheric Aerosol Optical depth at 550 nm ', '1', (/ ('', i=1, 10) /))
     1312    'OD550_strat_only', 'Stratospheric Aerosol Optical depth at 550 nm ', '1', (/ ('', i=1, 10) /))
    12951313  TYPE(ctrl_out), SAVE :: o_tau_strat_1020 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
    12961314    'OD1020_strat_only', 'Stratospheric Aerosol Optical depth at 1020 nm ', '1', (/ ('', i=1, 10) /))
    … …  
    13661384  TYPE(ctrl_out), SAVE :: o_temp = ctrl_out((/ 2, 3, 4, 10, 10, 10, 11, 11, 11, 11/), &
    13671385    'temp', 'Air temperature', 'K', (/ ('', i=1, 10) /))
     1386  TYPE(ctrl_out), SAVE :: o_heat_volc = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     1387    'heat_volc', 'SW heating rate due to volcano', 'K/s', (/ ('', i=1, 10) /))
     1388  TYPE(ctrl_out), SAVE :: o_cool_volc = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     1389    'cool_volc', 'LW cooling rate due to volcano', 'K/s', (/ ('', i=1, 10) /))
    13681390  TYPE(ctrl_out), SAVE :: o_theta = ctrl_out((/ 2, 3, 4, 10, 10, 10, 11, 11, 11, 11/), &
    13691391    'theta', 'Potential air temperature', 'K', (/ ('', i=1, 10) /))
    … …  
    15081530  TYPE(ctrl_out), SAVE :: o_clwcon = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
    15091531    'clwcon', 'Convective Cloud Liquid water content', 'kg/kg', (/ ('', i=1, 10) /))
     1532  TYPE(ctrl_out), SAVE :: o_Mipsh = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     1533    'Mipsh', 'mass flux shed from adiab. ascents', 'kg/m2/s', (/ ('', i=1, 10) /))
    15101534  TYPE(ctrl_out), SAVE :: o_Ma = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
    1511     'Ma', 'undilute adiab updraft', 'kg/m2/s', (/ ('', i=1, 10) /))
     1535    'Ma', 'undilute adiab updraft mass flux', 'kg/m2/s', (/ ('', i=1, 10) /))
    15121536  TYPE(ctrl_out), SAVE :: o_dnwd = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
    15131537    'dnwd', 'saturated downdraft', 'kg/m2/s', (/ ('', i=1, 10) /))
    … …  
    15731597  TYPE(ctrl_out), SAVE :: o_wdtrainA = ctrl_out((/ 4, 5, 10,  4, 10, 10, 11, 11, 11, 11 /), &
    15741598    'wdtrainA', 'precipitation from AA', '-', (/ ('', i=1, 10) /))
     1599  TYPE(ctrl_out), SAVE :: o_wdtrainS = ctrl_out((/ 4, 5, 10,  4, 10, 10, 11, 11, 11, 11 /), &
     1600    'wdtrainS', 'precipitation from shedding of AA', '-', (/ ('', i=1, 10) /))
    15751601  TYPE(ctrl_out), SAVE :: o_wdtrainM = ctrl_out((/ 4, 5, 10,  4, 10, 10, 11, 11, 11, 11 /), &
    15761602    'wdtrainM', 'precipitation from mixture', '-', (/ ('', i=1, 10) /))
    15771603  TYPE(ctrl_out), SAVE :: o_Vprecip = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
    15781604    'Vprecip', 'precipitation vertical profile', '-', (/ ('', i=1, 10) /))
     1605  TYPE(ctrl_out), SAVE :: o_qtaa = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     1606    'qtaa', 'specific total water in adiabatic ascents', 'kg/kg', (/ ('', i=1, 10) /))
     1607  TYPE(ctrl_out), SAVE :: o_clwaa = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     1608    'Clwaa', 'specific condensed water in adiabatic ascents', 'kg/kg', (/ ('', i=1, 10) /))
    15791609  TYPE(ctrl_out), SAVE :: o_ftd = ctrl_out((/ 4, 5, 10, 10, 10, 10, 11, 11, 11, 11/), &
    15801610    'ftd', 'tend temp due aux descentes precip', '-', (/ ('', i=1, 10) /))

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phys_output_mod.F90

    r3125 r3605  
    131131                                                                       90.,   90.,   90.,   90.,   90. /)
    132132    REAL, DIMENSION(klev,2) :: Ahyb_bounds, Bhyb_bounds
    133     REAL, DIMENSION(klev)   :: lev_index
     133    REAL, DIMENSION(klev+1)   :: lev_index
    134134               
    135135#ifdef CPP_XIOS
    … …  
    156156      lev_index(ilev) = REAL(ilev)
    157157    END DO
     158      lev_index(klev+1) = REAL(klev+1)
    158159
    159160    IF (.NOT. ALLOCATED(o_trac)) ALLOCATE(o_trac(nqtot))
    … …  
    361362    CALL wxios_add_vaxis("klev", levmax(iff) - levmin(iff) + 1, &
    362363                          lev_index(levmin(iff):levmax(iff)))
     364    CALL wxios_add_vaxis("klevp1", klev+1, &
     365                          lev_index(1:klev+1))
    363366    CALL wxios_add_vaxis("bnds", 2, (/1.,2./))
    364367

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phys_output_write_mod.F90

    r3601 r3605  
    1717  SUBROUTINE phys_output_write(itap, pdtphys, paprs, pphis, &
    1818       pplay, lmax_th, aerosol_couple,         &
    19        ok_ade, ok_aie, ivap, iliq, isol, new_aod, ok_sync, &
     19       ok_ade, ok_aie, ok_volcan, ivap, iliq, isol, new_aod, ok_sync, &
    2020       ptconv, read_climoz, clevSTD, ptconvth, &
    2121       d_u, d_t, qx, d_qx, zmasse, flag_aerosol, flag_aerosol_strat, ok_cdnc)
    … …  
    3232    USE phys_output_ctrlout_mod, ONLY: o_phis, o_aire, is_ter, is_lic, is_oce, &
    3333         o_longitude, o_latitude, &
    34          o_Ahyb, o_Bhyb,o_Ahyb_inter, o_Bhyb_inter, &
     34         o_Ahyb, o_Bhyb,o_Ahyb_bounds, o_Bhyb_bounds, &
     35         o_Ahyb_mid, o_Bhyb_mid,o_Ahyb_mid_bounds, o_Bhyb_mid_bounds, &
    3536         is_ave, is_sic, o_contfracATM, o_contfracOR, &
    3637         o_aireTER, o_flat, o_slp, o_ptstar, o_pt0, o_tsol, &
    … …  
    7273         o_uwat, o_vwat, &
    7374         o_ptop, o_fbase, o_plcl, o_plfc, &
    74          o_wbeff, o_convoccur, o_cape_max, o_upwd, o_ep,o_epmax_diag, o_Ma, &
     75         o_wbeff, o_convoccur, o_cape_max, o_upwd, o_ep,o_epmax_diag, &
     76         o_Mipsh, o_Ma, &
    7577         o_dnwd, o_dnwd0, o_ftime_deepcv, o_ftime_con, o_mc, &
    7678         o_prw, o_prlw, o_prsw, o_s_pblh, o_s_pblt, o_s_lcl, &
    … …  
    8789         o_wake_s, o_wake_deltat, o_wake_deltaq, &
    8890         o_wake_omg, o_dtwak, o_dqwak, o_dqwak2d, o_Vprecip, &
    89          o_ftd, o_fqd, o_wdtrainA, o_wdtrainM, &
     91         o_qtaa, o_Clwaa, &
     92         o_ftd, o_fqd, o_wdtrainA, o_wdtrainS, o_wdtrainM, &
    9093         o_n2, o_s2, o_proba_notrig, &
    9194         o_random_notrig, o_ale_bl_stat, &
    … …  
    196199! Tropopause
    197200         o_p_tropopause, o_z_tropopause, o_t_tropopause,  &
    198          o_col_O3_strato, o_col_O3_tropo, &               ! Added ThL
     201         o_col_O3_strato, o_col_O3_tropo,                 &
     202!--interactive CO2
     203         o_flx_co2_ocean, o_flx_co2_land, o_flx_co2_ff, o_flx_co2_bb, &
    199204         o_t_int, o_s_int, o_ds_ns, o_dt_ns, o_dter, o_dser, o_tkt, o_tks, &
    200205         o_rf, o_taur
    … …  
    214219         o_vsed_aer, o_tau_strat_1020, o_ext_strat_1020, o_f_r_wet
    215220#endif
     221   
     222    USE phys_output_ctrlout_mod, ONLY: o_heat_volc, o_cool_volc !NL
     223    USE phys_state_var_mod, ONLY: heat_volc, cool_volc !NL
    216224
    217225    USE phys_state_var_mod, ONLY: pctsrf, rain_fall, snow_fall, &
    … …  
    227235         delta_tsurf, &
    228236         wstar, cape, ema_pcb, ema_pct, &
    229          ema_cbmf, Ma, fm_therm, ale_bl, alp_bl, ale, &
     237         ema_cbmf, Mipsh, Ma, fm_therm, ale_bl, alp_bl, ale, &
    230238         alp, cin, wake_pe, wake_dens, wake_s, wake_deltat, &
    231239         wake_deltaq, ftd, fqd, ale_bl_trig, albsol1, &
    … …  
    244252
    245253    USE phys_local_var_mod, ONLY: zxfluxlat, slp, ptstar, pt0, zxtsol, zt2m, &
     254         zt2m_cor,zq2m_cor,zu10m_cor,zv10m_cor, zrh2m_cor, zqsat2m_cor, &
    246255         t2m_min_mon, t2m_max_mon, evap, &
    247256         l_mixmin,l_mix, &
    … …  
    267276         kh         ,kh_x       ,kh_w       , &
    268277         cv_gen, wake_h, &
    269          wake_omg, d_t_wake, d_q_wake, Vprecip, &
    270          wdtrainA, wdtrainM, n2, s2, proba_notrig, &
     278         wake_omg, d_t_wake, d_q_wake, Vprecip, qtaa, Clw, &
     279         wdtrainA, wdtrainS, wdtrainM, n2, s2, proba_notrig, &
    271280         random_notrig, &
    272281         alp_bl_det, alp_bl_fluct_m, alp_bl_conv, &
    … …  
    329338#endif
    330339
     340    USE carbon_cycle_mod, ONLY: fco2_ff, fco2_bb, fco2_land, fco2_ocean
     341
    331342    USE phys_output_var_mod, ONLY: vars_defined, snow_o, zfra_o, bils_diss, &
    332343         bils_ec,bils_ech, bils_tke, bils_kinetic, bils_latent, bils_enthalp, &
    … …  
    368379    ! ug Pour les sorties XIOS
    369380    USE xios
    370     USE wxios, ONLY: wxios_closedef, missing_val
     381    USE wxios, ONLY: wxios_closedef, missing_val, wxios_set_context
    371382#endif
    372383    USE phys_cal_mod, ONLY : mth_len
    … …  
    390401    INTEGER, DIMENSION(klon) :: lmax_th
    391402    LOGICAL :: aerosol_couple, ok_sync
    392     LOGICAL :: ok_ade, ok_aie, new_aod
     403    LOGICAL :: ok_ade, ok_aie, ok_volcan, new_aod
    393404    LOGICAL, DIMENSION(klon, klev) :: ptconv, ptconvth
    394405    REAL :: pdtphys
    … …  
    417428    REAL, PARAMETER :: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
    418429!   REAL, PARAMETER :: missing_val=nf90_fill_real
    419     REAL, DIMENSION(klev,2) :: Ahyb_bounds, Bhyb_bounds
     430    REAL, DIMENSION(klev+1,2) :: Ahyb_bounds, Bhyb_bounds
     431    REAL, DIMENSION(klev,2) :: Ahyb_mid_bounds, Bhyb_mid_bounds
    420432    INTEGER :: ilev
    421433#ifndef CPP_XIOS
    … …  
    440452    CALL set_itau_iophy(itau_w)
    441453
    442     IF (.NOT.vars_defined) THEN
    443        iinitend = 2
    444     ELSE
     454 !   IF (.NOT.vars_defined) THEN
    445455       iinitend = 1
    446     ENDIF
    447 
    448     DO ilev=1,klev
    449       Ahyb_bounds(ilev,1) = ap(ilev)
    450       Ahyb_bounds(ilev,2) = ap(ilev+1)
    451       Bhyb_bounds(ilev,1) = bp(ilev)
    452       Bhyb_bounds(ilev,2) = bp(ilev+1)
     456 !   ELSE
     457 !      iinitend = 1
     458 !   ENDIF
     459
     460#ifdef CPP_XIOS
     461    CALL wxios_set_context
     462#endif
     463
     464    Ahyb_bounds(1,1) = 0.
     465    Ahyb_bounds(1,2) = aps(1)
     466    Bhyb_bounds(1,1) = 1.
     467    Bhyb_bounds(1,2) = bps(1)   
     468    DO ilev=2,klev
     469      Ahyb_bounds(ilev,1) = aps(ilev-1)
     470      Ahyb_bounds(ilev,2) = aps(ilev)
     471      Bhyb_bounds(ilev,1) = bps(ilev-1)
     472      Bhyb_bounds(ilev,2) = bps(ilev)
     473    ENDDO
     474     Ahyb_bounds(klev+1,1) = aps(klev)
     475     Ahyb_bounds(klev+1,2) = 0.
     476     Bhyb_bounds(klev+1,1) = bps(klev)
     477     Bhyb_bounds(klev+1,2) = 0.
     478
     479    DO ilev=1, klev
     480      Ahyb_mid_bounds(ilev,1) = ap(ilev)
     481      Ahyb_mid_bounds(ilev,2) = ap(ilev+1)
     482      Bhyb_mid_bounds(ilev,1) = bp(ilev)
     483      Bhyb_mid_bounds(ilev,2) = bp(ilev+1)
    453484    END DO
    454485
    … …  
    565596       CALL histwrite_phy("R_incl",R_incl)
    566597       CALL histwrite_phy("solaire",solaire)
    567        CALL histwrite_phy(o_Ahyb, aps)
    568        CALL histwrite_phy(o_Bhyb, bps)
    569        CALL histwrite_phy(o_Ahyb_inter, Ahyb_bounds)
    570        CALL histwrite_phy(o_Bhyb_inter, Bhyb_bounds)
     598       CALL histwrite_phy(o_Ahyb, ap)
     599       CALL histwrite_phy(o_Bhyb, bp)
     600       CALL histwrite_phy(o_Ahyb_bounds, Ahyb_bounds)
     601       CALL histwrite_phy(o_Bhyb_bounds, Bhyb_bounds)
     602       CALL histwrite_phy(o_Ahyb_mid, aps)
     603       CALL histwrite_phy(o_Bhyb_mid, bps)
     604       CALL histwrite_phy(o_Ahyb_mid_bounds, Ahyb_mid_bounds)
     605       CALL histwrite_phy(o_Bhyb_mid_bounds, Bhyb_mid_bounds)
    571606       CALL histwrite_phy(o_longitude, longitude_deg)
    572607       CALL histwrite_phy(o_latitude, latitude_deg)
    … …  
    636671       CALL histwrite_phy(o_slp, slp)
    637672       CALL histwrite_phy(o_tsol, zxtsol)
    638        CALL histwrite_phy(o_t2m, zt2m)
    639        CALL histwrite_phy(o_t2m_min, zt2m)
    640        CALL histwrite_phy(o_t2m_max, zt2m)
     673       CALL histwrite_phy(o_t2m, zt2m_cor)
     674       CALL histwrite_phy(o_t2m_min, zt2m_cor)
     675       CALL histwrite_phy(o_t2m_max, zt2m_cor)
    641676       CALL histwrite_phy(o_t2m_max_mon, t2m_max_mon)
    642677       CALL histwrite_phy(o_t2m_min_mon, t2m_min_mon)
    … …  
    644679       IF (vars_defined) THEN
    645680          DO i=1, klon
    646              zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
     681             zx_tmp_fi2d(i)=SQRT(zu10m_cor(i)*zu10m_cor(i)+zv10m_cor(i)*zv10m_cor(i))
    647682          ENDDO
    648683       ENDIF
    … …  
    651686       IF (vars_defined) THEN
    652687          DO i=1, klon
    653              zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
     688             zx_tmp_fi2d(i)=SQRT(zu10m_cor(i)*zu10m_cor(i)+zv10m_cor(i)*zv10m_cor(i))
    654689          ENDDO
    655690       ENDIF
    … …  
    664699       ENDIF
    665700       CALL histwrite_phy(o_sicf, zx_tmp_fi2d)
    666        CALL histwrite_phy(o_q2m, zq2m)
     701       CALL histwrite_phy(o_q2m, zq2m_cor)
    667702       CALL histwrite_phy(o_ustar, zustar)
    668        CALL histwrite_phy(o_u10m, zu10m)
    669        CALL histwrite_phy(o_v10m, zv10m)
     703       CALL histwrite_phy(o_u10m, zu10m_cor)
     704       CALL histwrite_phy(o_v10m, zv10m_cor)
    670705
    671706       IF (vars_defined) THEN
    … …  
    716751       CALL histwrite_phy(o_fsnow, zfra_o)
    717752       CALL histwrite_phy(o_evap, evap)
    718        CALL histwrite_phy(o_tops, topsw*swradcorr)
    719        CALL histwrite_phy(o_tops0, topsw0*swradcorr)
     753
     754       IF (vars_defined) THEN
     755         zx_tmp_fi2d = topsw*swradcorr
     756       ENDIF
     757       CALL histwrite_phy(o_tops, zx_tmp_fi2d)
     758
     759       IF (vars_defined) THEN
     760         zx_tmp_fi2d = topsw0*swradcorr
     761       ENDIF
     762       CALL histwrite_phy(o_tops0, zx_tmp_fi2d)
     763
    720764       CALL histwrite_phy(o_topl, toplw)
    721765       CALL histwrite_phy(o_topl0, toplw0)
    … …  
    750794       ENDIF
    751795       CALL histwrite_phy(o_nettop, zx_tmp_fi2d)
    752        CALL histwrite_phy(o_SWup200, SWup200*swradcorr)
    753        CALL histwrite_phy(o_SWup200clr, SWup200clr*swradcorr)
    754        CALL histwrite_phy(o_SWdn200, SWdn200*swradcorr)
    755        CALL histwrite_phy(o_SWdn200clr, SWdn200clr*swradcorr)
     796       
     797       IF (vars_defined) THEN
     798          zx_tmp_fi2d = SWup200*swradcorr
     799       ENDIF
     800       CALL histwrite_phy(o_SWup200, zx_tmp_fi2d)
     801       
     802       IF (vars_defined) THEN
     803          zx_tmp_fi2d = SWup200clr*swradcorr
     804       ENDIF
     805       CALL histwrite_phy(o_SWup200clr, zx_tmp_fi2d)
     806       
     807       IF (vars_defined) THEN
     808          zx_tmp_fi2d = SWdn200*swradcorr
     809       ENDIF
     810       CALL histwrite_phy(o_SWdn200, zx_tmp_fi2d)
     811       
     812       
     813       IF (vars_defined) THEN
     814          zx_tmp_fi2d = SWdn200clr*swradcorr
     815       ENDIF
     816       CALL histwrite_phy(o_SWdn200clr, zx_tmp_fi2d)
     817       
    756818       CALL histwrite_phy(o_LWup200, LWup200)
    757819       CALL histwrite_phy(o_LWup200clr, LWup200clr)
    758820       CALL histwrite_phy(o_LWdn200, LWdn200)
    759821       CALL histwrite_phy(o_LWdn200clr, LWdn200clr)
    760        CALL histwrite_phy(o_sols, solsw*swradcorr)
    761        CALL histwrite_phy(o_sols0, solsw0*swradcorr)
     822       
     823       IF (vars_defined) THEN
     824          zx_tmp_fi2d = solsw*swradcorr
     825       ENDIF
     826       CALL histwrite_phy(o_sols, zx_tmp_fi2d)
     827       
     828       
     829       IF (vars_defined) THEN
     830          zx_tmp_fi2d = solsw0*swradcorr
     831       ENDIF
     832       CALL histwrite_phy(o_sols0, zx_tmp_fi2d)
    762833       CALL histwrite_phy(o_soll, sollw)
    763834       CALL histwrite_phy(o_soll0, sollw0)
    … …  
    909980          IF (iflag_pbl > 1) THEN
    910981             CALL histwrite_phy(o_tke_srf(nsrf),  pbl_tke(:,1:klev,nsrf))
    911              CALL histwrite_phy(o_l_mix(nsrf),  l_mix(:,1:klev,nsrf))
     982             !CALL histwrite_phy(o_l_mix(nsrf),  l_mix(:,1:klev,nsrf))
    912983             CALL histwrite_phy(o_l_mixmin(nsrf),  l_mixmin(:,1:klev,nsrf))
    913984             CALL histwrite_phy(o_tke_max_srf(nsrf),  pbl_tke(:,1:klev,nsrf))
    … …  
    9541025       CALL histwrite_phy(o_cldt, cldt)
    9551026       CALL histwrite_phy(o_JrNt, JrNt)
    956        CALL histwrite_phy(o_cldljn, cldl*JrNt)
    957        CALL histwrite_phy(o_cldmjn, cldm*JrNt)
    958        CALL histwrite_phy(o_cldhjn, cldh*JrNt)
    959        CALL histwrite_phy(o_cldtjn, cldt*JrNt)
     1027       
     1028       IF (vars_defined)  zx_tmp_fi2d=cldl*JrNt     
     1029       CALL histwrite_phy(o_cldljn, zx_tmp_fi2d)
     1030       
     1031       IF (vars_defined)  zx_tmp_fi2d=cldm*JrNt     
     1032       CALL histwrite_phy(o_cldmjn, zx_tmp_fi2d)
     1033       
     1034       IF (vars_defined)  zx_tmp_fi2d=cldh*JrNt
     1035       CALL histwrite_phy(o_cldhjn, zx_tmp_fi2d)
     1036       
     1037       IF (vars_defined)  zx_tmp_fi2d=cldt*JrNt
     1038       CALL histwrite_phy(o_cldtjn, zx_tmp_fi2d)
     1039       
    9601040       CALL histwrite_phy(o_cldq, cldq)
    9611041       IF (vars_defined)       zx_tmp_fi2d(1:klon) = flwp(1:klon)
    … …  
    11081188       ! Wakes
    11091189       IF (iflag_con.EQ.3) THEN
     1190          CALL histwrite_phy(o_Mipsh, Mipsh)
    11101191          IF (iflag_wake>=1) THEN
    11111192             CALL histwrite_phy(o_ale_wk, ale_wake)
    … …  
    11581239             IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_wake(1:klon,1:klev)/pdtphys
    11591240             CALL histwrite_phy(o_dqwak, zx_tmp_fi3d)
    1160              CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1241             IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    11611242             CALL histwrite_phy(o_dqwak2d, zx_tmp_fi2d)
    11621243          ENDIF ! iflag_wake>=1
    … …  
    11681249          ! etendue a iflag_con=3 (jyg)
    11691250          CALL histwrite_phy(o_Vprecip, Vprecip)
     1251          CALL histwrite_phy(o_qtaa, qtaa)
     1252          CALL histwrite_phy(o_clwaa, clw)
    11701253          CALL histwrite_phy(o_wdtrainA, wdtrainA)
     1254          CALL histwrite_phy(o_wdtrainS, wdtrainS)
    11711255          CALL histwrite_phy(o_wdtrainM, wdtrainM)
    11721256       ENDIF !(iflag_con.EQ.3.or.iflag_con.EQ.30)
    … …  
    12081292          IF (slab_gm) THEN
    12091293             CALL histwrite_phy(o_slab_gm, dt_gm(:,1:nslay))
    1210           END IF
     1294          ENDIF
    12111295          IF (slab_hdiff) THEN
    12121296            IF (nslay.EQ.1) THEN
    … …  
    12571341!       CALL histwrite_phy(o_rh2m_max, zx_tmp_fi2d)
    12581342
    1259        CALL histwrite_phy(o_qsat2m, qsat2m)
     1343       CALL histwrite_phy(o_qsat2m, zqsat2m_cor)
    12601344       CALL histwrite_phy(o_tpot, tpot)
    12611345       CALL histwrite_phy(o_tpote, tpote)
    … …  
    13221406
    13231407! ThL -- In the following, we assume read_climoz == 1
    1324        zx_tmp_fi2d = 0.0    ! Computation for strato, added ThL
    1325        DO k=1, klev
    1326           zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * stratomask(:,k) * 1.e3
    1327        END DO
     1408       IF (vars_defined) THEN
     1409         zx_tmp_fi2d = 0.0    ! Computation for strato, added ThL
     1410         DO k=1, klev
     1411            zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * stratomask(:,k) * 1.e3
     1412         END DO
     1413       ENDIF
    13281414       CALL histwrite_phy(o_col_O3_strato, zx_tmp_fi2d) ! Added ThL
    1329        zx_tmp_fi2d = 0.0    ! Computation for tropo, added ThL
    1330        DO k=1, klev
    1331           zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * (1.0-stratomask(:,k)) * 1.e3
    1332        END DO
     1415
     1416       IF (vars_defined) THEN
     1417         zx_tmp_fi2d = 0.0    ! Computation for tropo, added ThL
     1418         DO k=1, klev
     1419            zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * (1.0-stratomask(:,k)) * 1.e3
     1420         END DO
     1421       ENDIF
    13331422       CALL histwrite_phy(o_col_O3_tropo, zx_tmp_fi2d)   ! Added ThL
    13341423! end add ThL
    … …  
    13701459       ENDIF
    13711460#endif
     1461       !NL
     1462       IF (ok_volcan .AND. ok_ade) THEN
     1463          DO k=1, klev
     1464             IF (vars_defined) zx_tmp_fi3d(:,k)=heat_volc(:,k)*swradcorr(:)
     1465          ENDDO
     1466          CALL histwrite_phy(o_heat_volc, zx_tmp_fi3d)
     1467          DO k=1, klev
     1468             IF (vars_defined) zx_tmp_fi3d(:,k)=cool_volc(:,k)
     1469          ENDDO
     1470          CALL histwrite_phy(o_cool_volc, zx_tmp_fi3d)
     1471       ENDIF
    13721472       IF (ok_ade) THEN
    1373           CALL histwrite_phy(o_topswad, topswad_aero*swradcorr)
    1374           CALL histwrite_phy(o_topswad0, topswad0_aero*swradcorr)
    1375           CALL histwrite_phy(o_solswad, solswad_aero*swradcorr)
    1376           CALL histwrite_phy(o_solswad0, solswad0_aero*swradcorr)
     1473          IF (vars_defined) zx_tmp_fi2d(:)=topswad_aero*swradcorr
     1474          CALL histwrite_phy(o_topswad, zx_tmp_fi2d)
     1475         
     1476          IF (vars_defined) zx_tmp_fi2d(:)=topswad0_aero*swradcorr
     1477          CALL histwrite_phy(o_topswad0, zx_tmp_fi2d)
     1478                   
     1479          IF (vars_defined) zx_tmp_fi2d(:)=solswad_aero*swradcorr
     1480          CALL histwrite_phy(o_solswad, zx_tmp_fi2d)
     1481                   
     1482          IF (vars_defined) zx_tmp_fi2d(:)=solswad0_aero*swradcorr
     1483          CALL histwrite_phy(o_solswad0, zx_tmp_fi2d)
     1484         
    13771485          CALL histwrite_phy(o_toplwad, toplwad_aero)
    13781486          CALL histwrite_phy(o_toplwad0, toplwad0_aero)
    … …  
    13811489          !====MS forcing diagnostics
    13821490          IF (new_aod) THEN
    1383              zx_tmp_fi2d(:)=topsw_aero(:,1)*swradcorr(:)
     1491          !ym warning : topsw_aero, solsw_aero, topsw0_aero, solsw0_aero are not defined by model
     1492          !ym => init to 0 in radlwsw_m.F90 ztopsw_aero, zsolsw_aero, ztopsw0_aero, zsolsw0_aero
     1493
     1494             IF (vars_defined) zx_tmp_fi2d(:)=topsw_aero(:,1)*swradcorr(:)
    13841495             CALL histwrite_phy(o_swtoaas_nat,zx_tmp_fi2d)
    1385              zx_tmp_fi2d(:)=solsw_aero(:,1)*swradcorr(:)
     1496             IF (vars_defined) zx_tmp_fi2d(:)=solsw_aero(:,1)*swradcorr(:)
    13861497             CALL histwrite_phy(o_swsrfas_nat,zx_tmp_fi2d)
    1387              zx_tmp_fi2d(:)=topsw0_aero(:,1)*swradcorr(:)
     1498             IF (vars_defined) zx_tmp_fi2d(:)=topsw0_aero(:,1)*swradcorr(:)
    13881499             CALL histwrite_phy(o_swtoacs_nat,zx_tmp_fi2d)
    1389              zx_tmp_fi2d(:)=solsw0_aero(:,1)*swradcorr(:)
     1500             IF (vars_defined) zx_tmp_fi2d(:)=solsw0_aero(:,1)*swradcorr(:)
    13901501             CALL histwrite_phy(o_swsrfcs_nat,zx_tmp_fi2d)
    13911502             !ant
    1392              zx_tmp_fi2d(:)=topsw_aero(:,2)*swradcorr(:)
     1503             IF (vars_defined) zx_tmp_fi2d(:)=topsw_aero(:,2)*swradcorr(:)
    13931504             CALL histwrite_phy(o_swtoaas_ant,zx_tmp_fi2d)
    1394              zx_tmp_fi2d(:)=solsw_aero(:,2)*swradcorr(:)
     1505             IF (vars_defined) zx_tmp_fi2d(:)=solsw_aero(:,2)*swradcorr(:)
    13951506             CALL histwrite_phy(o_swsrfas_ant,zx_tmp_fi2d)
    1396              zx_tmp_fi2d(:)=topsw0_aero(:,2)*swradcorr(:)
     1507             IF (vars_defined) zx_tmp_fi2d(:)=topsw0_aero(:,2)*swradcorr(:)
    13971508             CALL histwrite_phy(o_swtoacs_ant,zx_tmp_fi2d)
    1398              zx_tmp_fi2d(:)=solsw0_aero(:,2)*swradcorr(:)
     1509             IF (vars_defined) zx_tmp_fi2d(:)=solsw0_aero(:,2)*swradcorr(:)
    13991510             CALL histwrite_phy(o_swsrfcs_ant,zx_tmp_fi2d)
    14001511             !cf
    14011512             IF (.not. aerosol_couple) THEN
    1402                 zx_tmp_fi2d(:)=topswcf_aero(:,1)*swradcorr(:)
     1513                IF (vars_defined) zx_tmp_fi2d(:)=topswcf_aero(:,1)*swradcorr(:)
    14031514                CALL histwrite_phy(o_swtoacf_nat,zx_tmp_fi2d)
    1404                 zx_tmp_fi2d(:)=solswcf_aero(:,1)*swradcorr(:)
     1515                IF (vars_defined) zx_tmp_fi2d(:)=solswcf_aero(:,1)*swradcorr(:)
    14051516                CALL histwrite_phy(o_swsrfcf_nat,zx_tmp_fi2d)
    1406                 zx_tmp_fi2d(:)=topswcf_aero(:,2)*swradcorr(:)
     1517                IF (vars_defined) zx_tmp_fi2d(:)=topswcf_aero(:,2)*swradcorr(:)
    14071518                CALL histwrite_phy(o_swtoacf_ant,zx_tmp_fi2d)
    1408                 zx_tmp_fi2d(:)=solswcf_aero(:,2)*swradcorr(:)
     1519                IF (vars_defined) zx_tmp_fi2d(:)=solswcf_aero(:,2)*swradcorr(:)
    14091520                CALL histwrite_phy(o_swsrfcf_ant,zx_tmp_fi2d)
    1410                 zx_tmp_fi2d(:)=topswcf_aero(:,3)*swradcorr(:)
     1521                IF (vars_defined) zx_tmp_fi2d(:)=topswcf_aero(:,3)*swradcorr(:)
    14111522                CALL histwrite_phy(o_swtoacf_zero,zx_tmp_fi2d)
    1412                 zx_tmp_fi2d(:)=solswcf_aero(:,3)*swradcorr(:)
     1523                IF (vars_defined) zx_tmp_fi2d(:)=solswcf_aero(:,3)*swradcorr(:)
    14131524                CALL histwrite_phy(o_swsrfcf_zero,zx_tmp_fi2d)
    14141525             ENDIF
    … …  
    14171528       ENDIF
    14181529       IF (ok_aie) THEN
    1419           CALL histwrite_phy(o_topswai, topswai_aero*swradcorr)
    1420           CALL histwrite_phy(o_toplwai, toplwai_aero*swradcorr)
    1421           CALL histwrite_phy(o_solswai, solswai_aero*swradcorr)
    1422           CALL histwrite_phy(o_sollwai, sollwai_aero*swradcorr)
     1530          IF (vars_defined) zx_tmp_fi2d(:)= topswai_aero*swradcorr
     1531          CALL histwrite_phy(o_topswai, zx_tmp_fi2d)
     1532         
     1533          IF (vars_defined) zx_tmp_fi2d(:)=toplwai_aero*swradcorr
     1534          CALL histwrite_phy(o_toplwai, zx_tmp_fi2d)
     1535         
     1536          IF (vars_defined) zx_tmp_fi2d(:)=solswai_aero*swradcorr
     1537          CALL histwrite_phy(o_solswai, zx_tmp_fi2d)
     1538         
     1539          IF (vars_defined) zx_tmp_fi2d(:)=sollwai_aero*swradcorr
     1540          CALL histwrite_phy(o_sollwai, zx_tmp_fi2d)
    14231541       ENDIF
    14241542       IF (flag_aerosol.GT.0.AND.ok_cdnc) THEN
    … …  
    14351553          CALL histwrite_phy(o_icc3dstra, icc3dstra)
    14361554          CALL histwrite_phy(o_cldicemxrat, zfice)
    1437           zx_tmp_fi3d(:,:)=1-zfice(:,:)
     1555          IF (vars_defined) zx_tmp_fi3d(:,:)=1-zfice(:,:)
    14381556          CALL histwrite_phy(o_cldwatmxrat, zx_tmp_fi3d)
    14391557          CALL histwrite_phy(o_reffclwtop, reffclwtop)
    … …  
    14501568       CALL histwrite_phy(o_ovap, q_seri)
    14511569       CALL histwrite_phy(o_oliq, ql_seri)
    1452        CALL histwrite_phy(o_ocond, ql_seri+qs_seri)
     1570
     1571       IF (vars_defined) zx_tmp_fi3d = ql_seri+qs_seri
     1572       CALL histwrite_phy(o_ocond, zx_tmp_fi3d)
     1573
    14531574       CALL histwrite_phy(o_geop, zphi)
    14541575       CALL histwrite_phy(o_vitu, u_seri)
    … …  
    14571578       CALL histwrite_phy(o_pres, pplay)
    14581579       CALL histwrite_phy(o_paprs, paprs(:,1:klev))
    1459        CALL histwrite_phy(o_zfull,zphi/RG)
     1580       
     1581       IF (vars_defined) zx_tmp_fi3d = zphi/RG
     1582       CALL histwrite_phy(o_zfull,zx_tmp_fi3d)
    14601583
    14611584#ifdef CPP_XIOS
    … …  
    15021625       CALL histwrite_phy(o_rnebjn, zx_tmp_fi3d)
    15031626       CALL histwrite_phy(o_rhum, zx_rh)
    1504        CALL histwrite_phy(o_ozone, &
    1505             wo(:, :, 1) * dobson_u * 1e3 / zmasse / rmo3 * rmd)
     1627       
     1628       IF (vars_defined) zx_tmp_fi3d = wo(:, :, 1) * dobson_u * 1e3 / zmasse / rmo3 * rmd
     1629       CALL histwrite_phy(o_ozone, zx_tmp_fi3d)
    15061630
    15071631       IF (read_climoz == 2) THEN
    1508           CALL histwrite_phy(o_ozone_light, &
    1509                wo(:, :, 2) * dobson_u * 1e3 / zmasse / rmo3 * rmd)
     1632         IF (vars_defined) zx_tmp_fi3d = wo(:, :, 2) * dobson_u * 1e3 / zmasse / rmo3 * rmd
     1633         CALL histwrite_phy(o_ozone_light, zx_tmp_fi3d)
    15101634       ENDIF
    15111635
    … …  
    15151639
    15161640       CALL histwrite_phy(o_dqphy,  d_qx(:,:,ivap))
    1517        CALL water_int(klon,klev,d_qx(:,:,ivap),zmasse,zx_tmp_fi2d)
     1641       IF (vars_defined) CALL water_int(klon,klev,d_qx(:,:,ivap),zmasse,zx_tmp_fi2d)
    15181642       CALL histwrite_phy(o_dqphy2d,  zx_tmp_fi2d)
    15191643
    15201644       CALL histwrite_phy(o_dqlphy,  d_qx(:,:,iliq))
    1521        CALL water_int(klon,klev,d_qx(:,:,iliq),zmasse,zx_tmp_fi2d)
     1645       IF (vars_defined) CALL water_int(klon,klev,d_qx(:,:,iliq),zmasse,zx_tmp_fi2d)
    15221646       CALL histwrite_phy(o_dqlphy2d,  zx_tmp_fi2d)
    15231647
    15241648       IF (nqo.EQ.3) THEN
    15251649       CALL histwrite_phy(o_dqsphy,  d_qx(:,:,isol))
    1526        CALL water_int(klon,klev,d_qx(:,:,isol),zmasse,zx_tmp_fi2d)
     1650       IF (vars_defined) CALL water_int(klon,klev,d_qx(:,:,isol),zmasse,zx_tmp_fi2d)
    15271651       CALL histwrite_phy(o_dqsphy2d,  zx_tmp_fi2d)
    15281652       ELSE
    … …  
    15891713       ENDIF
    15901714       CALL histwrite_phy(o_dtcon, zx_tmp_fi3d)
    1591        if(iflag_thermals.eq.0)then
     1715       IF (iflag_thermals.EQ.0) THEN
    15921716          IF (vars_defined) THEN
    15931717             zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + &
    … …  
    15951719          ENDIF
    15961720          CALL histwrite_phy(o_tntc, zx_tmp_fi3d)
    1597        else if(iflag_thermals.ge.1.and.iflag_wake.EQ.1)then
     1721       ELSE IF(iflag_thermals.GE.1.AND.iflag_wake.EQ.1) THEN
    15981722          IF (vars_defined) THEN
    15991723             zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + &
    … …  
    16021726          ENDIF
    16031727          CALL histwrite_phy(o_tntc, zx_tmp_fi3d)
    1604        endif
     1728       ENDIF
    16051729       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys
    16061730       CALL histwrite_phy(o_ducon, zx_tmp_fi3d)
    … …  
    16091733       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
    16101734       CALL histwrite_phy(o_dqcon, zx_tmp_fi3d)
    1611        CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1735       IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    16121736       CALL histwrite_phy(o_dqcon2d, zx_tmp_fi2d)
    16131737
    … …  
    16311755       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
    16321756       CALL histwrite_phy(o_dqlsc, zx_tmp_fi3d)
    1633        CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1757       IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    16341758       CALL histwrite_phy(o_dqlsc2d, zx_tmp_fi2d)
    16351759       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=beta_prec(1:klon,1:klev)
    … …  
    16441768          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_lscth(1:klon,1:klev)/pdtphys
    16451769          CALL histwrite_phy(o_dqlscth, zx_tmp_fi3d)
    1646           CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1770          IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    16471771          CALL histwrite_phy(o_dqlscth2d, zx_tmp_fi2d)
    16481772          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_lscst(1:klon,1:klev)/pdtphys
    16491773          CALL histwrite_phy(o_dqlscst, zx_tmp_fi3d)
    1650           CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1774          IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    16511775          CALL histwrite_phy(o_dqlscst2d, zx_tmp_fi2d)
    16521776          CALL histwrite_phy(o_plulth, plul_th)
    16531777          CALL histwrite_phy(o_plulst, plul_st)
    16541778          IF (vars_defined) THEN
    1655              do i=1,klon
     1779             DO i=1,klon
    16561780                zx_tmp_fi2d(1:klon)=lmax_th(:)
    1657              enddo
     1781             ENDDO
    16581782          ENDIF
    16591783          CALL histwrite_phy(o_lmaxth, zx_tmp_fi2d)
    … …  
    17021826       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
    17031827       CALL histwrite_phy(o_dqvdf, zx_tmp_fi3d)
    1704        CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1828       IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    17051829       CALL histwrite_phy(o_dqvdf2d, zx_tmp_fi2d)
    17061830       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
    … …  
    17081832       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
    17091833       CALL histwrite_phy(o_dqeva, zx_tmp_fi3d)
    1710        CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1834       IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    17111835       CALL histwrite_phy(o_dqeva2d, zx_tmp_fi2d)
    17121836       CALL histwrite_phy(o_ratqs, ratqs)
    … …  
    17471871          ENDIF
    17481872          CALL histwrite_phy(o_dqthe, zx_tmp_fi3d)
    1749           CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1873          IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    17501874          CALL histwrite_phy(o_dqthe2d, zx_tmp_fi2d)
    17511875       ENDIF !iflag_thermals
    … …  
    17541878       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
    17551879       CALL histwrite_phy(o_dqajs, zx_tmp_fi3d)
    1756        CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
     1880       IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)
    17571881       CALL histwrite_phy(o_dqajs2d, zx_tmp_fi2d)
    17581882       IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_swr(1:klon,1:klev)/pdtphys
    … …  
    17901914
    17911915       IF (ok_hines) THEN
    1792           CALL histwrite_phy(o_du_gwd_hines, du_gwd_hines/pdtphys)
    1793           CALL histwrite_phy(o_dv_gwd_hines, dv_gwd_hines/pdtphys)
     1916          IF (vars_defined) zx_tmp_fi3d=du_gwd_hines/pdtphys
     1917          CALL histwrite_phy(o_du_gwd_hines, zx_tmp_fi3d)
     1918
     1919          IF (vars_defined) zx_tmp_fi3d= dv_gwd_hines/pdtphys         
     1920          CALL histwrite_phy(o_dv_gwd_hines, zx_tmp_fi3d)
     1921         
    17941922          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_hin(1:klon,1:klev)/pdtphys
    17951923          CALL histwrite_phy(o_dthin, zx_tmp_fi3d)
    … …  
    17991927
    18001928       IF (.not. ok_hines .and. ok_gwd_rando) THEN
    1801           CALL histwrite_phy(o_du_gwd_front, du_gwd_front / pdtphys)
    1802           CALL histwrite_phy(o_dv_gwd_front, dv_gwd_front / pdtphys)
     1929          IF (vars_defined)  zx_tmp_fi3d=du_gwd_front / pdtphys
     1930          CALL histwrite_phy(o_du_gwd_front, zx_tmp_fi3d)
     1931         
     1932          IF (vars_defined)  zx_tmp_fi3d=dv_gwd_front / pdtphys
     1933          CALL histwrite_phy(o_dv_gwd_front, zx_tmp_fi3d)
     1934         
    18031935          CALL histwrite_phy(o_ustr_gwd_front, zustr_gwd_front)
    18041936          CALL histwrite_phy(o_vstr_gwd_front, zvstr_gwd_front)
    … …  
    18061938
    18071939       IF (ok_gwd_rando) THEN
    1808           CALL histwrite_phy(o_du_gwd_rando, du_gwd_rando / pdtphys)
    1809           CALL histwrite_phy(o_dv_gwd_rando, dv_gwd_rando / pdtphys)
     1940          IF (vars_defined)  zx_tmp_fi3d=du_gwd_rando / pdtphys
     1941          CALL histwrite_phy(o_du_gwd_rando, zx_tmp_fi3d)
     1942         
     1943          IF (vars_defined)  zx_tmp_fi3d=dv_gwd_rando / pdtphys
     1944          CALL histwrite_phy(o_dv_gwd_rando, zx_tmp_fi3d)
    18101945          CALL histwrite_phy(o_ustr_gwd_rando, zustr_gwd_rando)
    18111946          CALL histwrite_phy(o_vstr_gwd_rando, zvstr_gwd_rando)
    … …  
    18151950
    18161951       IF (ok_qch4) THEN
    1817           CALL histwrite_phy(o_dqch4, d_q_ch4 / pdtphys)
    1818        ENDIF
    1819 
    1820        DO k=1, klevp1
    1821          zx_tmp_fi3d1(:,k)=swup(:,k)*swradcorr(:)
    1822        ENDDO
     1952          IF (vars_defined) zx_tmp_fi3d=d_q_ch4 / pdtphys
     1953          CALL histwrite_phy(o_dqch4, zx_tmp_fi3d)
     1954       ENDIF
     1955       
     1956       IF (vars_defined) THEN
     1957         DO k=1, klevp1
     1958           zx_tmp_fi3d1(:,k)=swup(:,k)*swradcorr(:)
     1959         ENDDO
     1960       ENDIF
     1961       
    18231962       CALL histwrite_phy(o_rsu, zx_tmp_fi3d1)
    1824        DO k=1, klevp1
    1825          zx_tmp_fi3d1(:,k)=swdn(:,k)*swradcorr(:)
    1826        ENDDO
     1963
     1964
     1965       IF (vars_defined) THEN
     1966         DO k=1, klevp1
     1967           zx_tmp_fi3d1(:,k)=swdn(:,k)*swradcorr(:)
     1968         ENDDO
     1969       ENDIF
     1970       
    18271971       CALL histwrite_phy(o_rsd, zx_tmp_fi3d1)
    1828        DO k=1, klevp1
    1829          zx_tmp_fi3d1(:,k)=swup0(:,k)*swradcorr(:)
    1830        ENDDO
     1972
     1973       IF (vars_defined) THEN
     1974         DO k=1, klevp1
     1975           zx_tmp_fi3d1(:,k)=swup0(:,k)*swradcorr(:)
     1976         ENDDO
     1977       ENDIF
     1978       
    18311979       CALL histwrite_phy(o_rsucs, zx_tmp_fi3d1)
    1832        DO k=1, klevp1
    1833          zx_tmp_fi3d1(:,k)=swupc0(:,k)*swradcorr(:)
    1834        ENDDO
     1980
     1981       IF (vars_defined) THEN
     1982         DO k=1, klevp1
     1983           zx_tmp_fi3d1(:,k)=swupc0(:,k)*swradcorr(:)
     1984         ENDDO
     1985       ENDIF
    18351986       CALL histwrite_phy(o_rsucsaf, zx_tmp_fi3d1)
    1836        DO k=1, klevp1
    1837          zx_tmp_fi3d1(:,k)=swdn0(:,k)*swradcorr(:)
    1838        ENDDO
     1987
     1988       IF (vars_defined) THEN
     1989         DO k=1, klevp1
     1990           zx_tmp_fi3d1(:,k)=swdn0(:,k)*swradcorr(:)
     1991         ENDDO
     1992       ENDIF
    18391993       CALL histwrite_phy(o_rsdcs, zx_tmp_fi3d1)
    1840        DO k=1, klevp1
    1841          zx_tmp_fi3d1(:,k)=swdnc0(:,k)*swradcorr(:)
    1842        ENDDO
     1994
     1995
     1996       IF (vars_defined) THEN
     1997         DO k=1, klevp1
     1998           zx_tmp_fi3d1(:,k)=swdnc0(:,k)*swradcorr(:)
     1999         ENDDO
     2000       ENDIF
    18432001       CALL histwrite_phy(o_rsdcsaf, zx_tmp_fi3d1)
    18442002
    … …  
    18942052       ELSE IF (iflag_con == 2) THEN
    18952053          CALL histwrite_phy(o_mcd,  pmfd)
    1896           CALL histwrite_phy(o_dmc,  pmfu + pmfd)
     2054          IF (vars_defined) zx_tmp_fi3d = pmfu + pmfd
     2055          CALL histwrite_phy(o_dmc,  zx_tmp_fi3d)
    18972056       ENDIF
    18982057       CALL histwrite_phy(o_ref_liq, ref_liq)
    … …  
    19082067          IF (vars_defined) zx_tmp_fi2d(:) = lwup0p(:,klevp1)
    19092068          CALL histwrite_phy(o_rlutcs4co2, zx_tmp_fi2d)
    1910           DO k=1, klevp1
    1911             zx_tmp_fi3d1(:,k)=swupp(:,k)*swradcorr(:)
    1912           ENDDO
     2069          IF (vars_defined) THEN
     2070            DO k=1, klevp1
     2071              zx_tmp_fi3d1(:,k)=swupp(:,k)*swradcorr(:)
     2072            ENDDO
     2073          ENDIF
    19132074          CALL histwrite_phy(o_rsu4co2, zx_tmp_fi3d1)
    1914           DO k=1, klevp1
    1915             zx_tmp_fi3d1(:,k)=swup0p(:,k)*swradcorr(:)
    1916           ENDDO
     2075          IF (vars_defined) THEN
     2076            DO k=1, klevp1
     2077              zx_tmp_fi3d1(:,k)=swup0p(:,k)*swradcorr(:)
     2078            ENDDO
     2079          ENDIF
    19172080          CALL histwrite_phy(o_rsucs4co2, zx_tmp_fi3d1)
    1918           DO k=1, klevp1
    1919             zx_tmp_fi3d1(:,k)=swdnp(:,k)*swradcorr(:)
    1920           ENDDO
     2081          IF (vars_defined) THEN
     2082            DO k=1, klevp1
     2083              zx_tmp_fi3d1(:,k)=swdnp(:,k)*swradcorr(:)
     2084            ENDDO
     2085          ENDIF
    19212086          CALL histwrite_phy(o_rsd4co2, zx_tmp_fi3d1)
    1922           DO k=1, klevp1
    1923             zx_tmp_fi3d1(:,k)=swdn0p(:,k)*swradcorr(:)
    1924           ENDDO
     2087          IF (vars_defined) THEN
     2088            DO k=1, klevp1
     2089              zx_tmp_fi3d1(:,k)=swdn0p(:,k)*swradcorr(:)
     2090            ENDDO
     2091          ENDIF
    19252092          CALL histwrite_phy(o_rsdcs4co2, zx_tmp_fi3d1)
    19262093          CALL histwrite_phy(o_rlu4co2, lwupp)
    … …  
    20712238!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    20722239       IF (iflag_phytrac == 1 ) then
    2073        IF (nqtot.GE.nqo+1) THEN
    2074           DO iq=nqo+1, nqtot
    2075             IF (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac == 'coag') THEN
     2240         IF (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac == 'coag') THEN
     2241           DO iq=nqo+1, nqtot
    20762242             !--3D fields
    20772243             CALL histwrite_phy(o_trac(iq-nqo), tr_seri(:,:,iq-nqo))
    … …  
    20892255             CALL histwrite_phy(o_dtr_sat(iq-nqo),d_tr_sat(:,:,iq-nqo))
    20902256             CALL histwrite_phy(o_dtr_uscav(iq-nqo),d_tr_uscav(:,:,iq-nqo))
    2091              !--2D fields
     2257            !--2D fields
    20922258             CALL histwrite_phy(o_dtr_dry(iq-nqo), flux_tr_dry(:,iq-nqo))
    20932259             zx_tmp_fi2d=0.
    … …  
    21002266             CALL histwrite_phy(o_trac_cum(iq-nqo), zx_tmp_fi2d)
    21012267#endif
    2102             ENDIF
    2103           ENDDO
    2104        ENDIF
    2105 
    2106        IF (type_trac == 'repr') THEN
     2268           ENDDO !--iq
     2269         ENDIF   !--type_trac
     2270!
     2271         IF (type_trac == 'co2i') THEN
     2272           DO iq=nqo+1, nqtot
     2273             !--3D fields
     2274             CALL histwrite_phy(o_trac(iq-nqo), tr_seri(:,:,iq-nqo))
     2275             CALL histwrite_phy(o_dtr_vdf(iq-nqo),d_tr_cl(:,:,iq-nqo))
     2276             CALL histwrite_phy(o_dtr_the(iq-nqo),d_tr_th(:,:,iq-nqo))
     2277             CALL histwrite_phy(o_dtr_con(iq-nqo),d_tr_cv(:,:,iq-nqo))
     2278             !--2D fields
     2279             !--CO2 burden
     2280             zx_tmp_fi2d=0.
     2281             IF (vars_defined) THEN
     2282                DO k=1,klev
     2283                   zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*tr_seri(:,k,iq-nqo)
     2284                ENDDO
     2285             ENDIF
     2286             CALL histwrite_phy(o_trac_cum(iq-nqo), zx_tmp_fi2d)
     2287           ENDDO !--iq
     2288           !--CO2 net fluxes
     2289           CALL histwrite_phy(o_flx_co2_land,  fco2_land)
     2290           CALL histwrite_phy(o_flx_co2_ocean, fco2_ocean)
     2291           CALL histwrite_phy(o_flx_co2_ff,    fco2_ff)
     2292           CALL histwrite_phy(o_flx_co2_bb,    fco2_bb)
     2293         ENDIF !--type_trac co2i
     2294
     2295         IF (type_trac == 'repr') THEN
    21072296#ifdef REPROBUS
    21082297           DO iq=1,nbnas
    … …  
    21102299           ENDDO
    21112300#endif
    2112        ENDIF
     2301         ENDIF
    21132302
    21142303       ENDIF   !(iflag_phytrac==1)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phys_state_var_mod.F90

    r3458 r3605  
    1818      INTEGER, SAVE :: radpas  ! radiation is called every "radpas" step
    1919      INTEGER, SAVE :: cvpas   ! convection is called every "cvpas" step
    20       INTEGER, SAVE :: cvpas_0 ! reference value for cvpas
     20      INTEGER, SAVE :: cvpas_0 = 1 ! reference value for cvpas
    2121      INTEGER, SAVE :: wkpas   ! wake scheme is called every "wkpas" step
    2222      REAL, PARAMETER :: missing_val_nf90=nf90_fill_real
    … …  
    2525!$OMP THREADPRIVATE(cvpas_0)
    2626!$OMP THREADPRIVATE(wkpas)
    27       REAL, SAVE :: dtime, solaire_etat0
    28 !$OMP THREADPRIVATE(dtime, solaire_etat0)
     27      REAL, SAVE :: phys_tstep=0, solaire_etat0
     28!$OMP THREADPRIVATE(phys_tstep, solaire_etat0)
    2929
    3030      REAL, ALLOCATABLE, SAVE :: pctsrf(:,:)
    … …  
    202202      REAL,ALLOCATABLE,SAVE :: ema_pcb(:), ema_pct(:)
    203203!$OMP THREADPRIVATE(ema_pcb,ema_pct)
    204       REAL,ALLOCATABLE,SAVE :: Ma(:,:)        ! undilute upward mass flux
     204      REAL,ALLOCATABLE,SAVE :: Mipsh(:,:)     ! mass flux shed from  adiab. ascents
     205!$OMP THREADPRIVATE(Mipsh)
     206      REAL,ALLOCATABLE,SAVE :: Ma(:,:)       ! undilute upward mass flux
    205207!$OMP THREADPRIVATE(Ma)
    206208      REAL,ALLOCATABLE,SAVE :: qcondc(:,:)    ! in-cld water content from convect
    … …  
    286288      REAL,ALLOCATABLE,SAVE :: total_rain(:), nday_rain(:) 
    287289!$OMP THREADPRIVATE(total_rain,nday_rain)
     290      REAL,ALLOCATABLE,SAVE :: paire_ter(:)
     291!$OMP THREADPRIVATE(paire_ter)
    288292! albsol1: albedo du sol total pour SW visible
    289293! albsol2: albedo du sol total pour SW proche IR
    … …  
    312316! toplwdown : downward CS LW flux at TOA
    313317! toplwdownclr : downward CS LW flux at TOA
     318! heat_volc : chauffage solaire du au volcanisme
     319! cool_volc : refroidissement infrarouge du au volcanisme
    314320      REAL,ALLOCATABLE,SAVE :: clwcon0(:,:),rnebcon0(:,:)
    315321!$OMP THREADPRIVATE(clwcon0,rnebcon0)
    … …  
    322328      REAL,ALLOCATABLE,SAVE :: cool0(:,:)
    323329!$OMP THREADPRIVATE(cool0)
     330      REAL,ALLOCATABLE,SAVE :: heat_volc(:,:)   
     331!$OMP THREADPRIVATE(heat_volc)
     332      REAL,ALLOCATABLE,SAVE :: cool_volc(:,:)
     333!$OMP THREADPRIVATE(cool_volc)
    324334      REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:)
    325335!$OMP THREADPRIVATE(topsw,toplw)
    … …  
    417427      ! tendencies on wind due to gravity waves
    418428
     429      LOGICAL,SAVE :: is_initialized=.FALSE.
     430!$OMP THREADPRIVATE(is_initialized)   
     431
    419432      ! Ocean-atmosphere interface, subskin ocean and near-surface ocean:
    420433     
    … …  
    452465include "clesphys.h"
    453466
     467      IF (is_initialized) RETURN
     468      is_initialized=.TRUE.
    454469      ALLOCATE(pctsrf(klon,nbsrf))
    455470      ALLOCATE(ftsol(klon,nbsrf))
    … …  
    467482      ALLOCATE(snow_fall(klon))
    468483      ALLOCATE(solsw(klon), sollw(klon))
     484      sollw=0.0
    469485      ALLOCATE(radsol(klon))
    470486      ALLOCATE(swradcorr(klon))
    … …  
    542558      ALLOCATE(ema_pcb(klon), ema_pct(klon))
    543559!
     560      ALLOCATE(Mipsh(klon,klev))
    544561      ALLOCATE(Ma(klon,klev))
    545562      ALLOCATE(qcondc(klon,klev))
    … …  
    551568      ALLOCATE(ale_wake(klon))
    552569      ALLOCATE(ale_bl_stat(klon))
     570      ale_bl_stat(:)=0
    553571      ALLOCATE(Alp_bl(klon))
    554572      ALLOCATE(lalim_conv(klon))
    … …  
    556574      ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev))
    557575      ALLOCATE(wake_s(klon), awake_dens(klon), wake_dens(klon))
     576      awake_dens = 0.
    558577      ALLOCATE(wake_Cstar(klon))
    559578      ALLOCATE(wake_pe(klon), wake_fip(klon))
    … …  
    564583      ALLOCATE(pfrac_1nucl(klon,klev))
    565584      ALLOCATE(total_rain(klon), nday_rain(klon))
     585      ALLOCATE(paire_ter(klon))
    566586      ALLOCATE(albsol1(klon), albsol2(klon))
    567587!albedo SB >>>
    … …  
    579599      ALLOCATE(heat(klon,klev), heat0(klon,klev))
    580600      ALLOCATE(cool(klon,klev), cool0(klon,klev))
     601      ALLOCATE(heat_volc(klon,klev), cool_volc(klon,klev))
    581602      ALLOCATE(topsw(klon), toplw(klon))
    582603      ALLOCATE(sollwdown(klon), sollwdownclr(klon))
     604      sollwdown = 0.
    583605      ALLOCATE(toplwdown(klon), toplwdownclr(klon))
    584606      ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon))
     607      sollw0 = 0.
    585608      ALLOCATE(albpla(klon))
    586609!IM ajout variables CFMIP2/CMIP5
    … …  
    619642      ALLOCATE(ale_bl_trig(klon))
    620643!!! fin nrlmd le 10/04/2012
    621       if (ok_gwd_rando) allocate(du_gwd_rando(klon, klev))
    622       if (.not. ok_hines .and. ok_gwd_rando) allocate(du_gwd_front(klon, klev))
    623 
     644      IF (ok_gwd_rando) THEN
     645        allocate(du_gwd_rando(klon, klev))
     646        du_gwd_rando(:,:)=0.
     647      ENDIF
     648      IF (.not. ok_hines .and. ok_gwd_rando) THEN
     649        ALLOCATE(du_gwd_front(klon, klev))
     650        du_gwd_front(:,:) = 0 !ym missing init   
     651      ENDIF
    624652      if (activate_ocean_skin >= 1) ALLOCATE(ds_ns(klon), dt_ns(klon))
    625653
    … …  
    693721      deallocate(ema_cbmf)
    694722      deallocate(ema_pcb, ema_pct)
    695       deallocate(Ma, qcondc)
     723      deallocate(Mipsh, Ma, qcondc)
    696724      deallocate(wd, sigd)
    697725      deallocate(cin, ALE, ALP)
    … …  
    710738      deallocate(pfrac_1nucl)
    711739      deallocate(total_rain, nday_rain)
     740      deallocate(paire_ter)
    712741      deallocate(albsol1, albsol2)
    713742!albedo SB >>>
    … …  
    718747      deallocate(heat, heat0)
    719748      deallocate(cool, cool0)
     749      deallocate(heat_volc, cool_volc)
    720750      deallocate(topsw, toplw)
    721751      deallocate(sollwdown, sollwdownclr)
    … …  
    757787      deallocate(ale_bl_trig)
    758788!!! fin nrlmd le 10/04/2012
     789
    759790      if (activate_ocean_skin >= 1) deALLOCATE(ds_ns, dt_ns)
    760791
     792      is_initialized=.FALSE.
     793     
    761794END SUBROUTINE phys_state_var_end
    762795

  • LMDZ6/branches/Ocean_skin/libf/phylmd/physiq_mod.F90

    r3418 r3605  
    2525    USE dimphy
    2626    USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac
    27     USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo
     27    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo, grid1dTo2d_glo, grid_type, unstructured
    2828    USE mod_phys_lmdz_para
    2929    USE iophy
    … …  
    3838#ifdef CPP_Dust
    3939    USE phytracr_spl_mod, ONLY: phytracr_spl
     40#endif
     41#ifdef CPP_StratAer
     42    USE strataer_mod, ONLY: strataer_init
    4043#endif
    4144    USE phys_local_var_mod, ONLY: phys_local_var_init, phys_local_var_end, &
    … …  
    117120       zustar, zu10m, zv10m, rh2m, qsat2m, &
    118121       zq2m, zt2m, weak_inversion, &
     122       zq2m_cor,zt2m_cor,zu10m_cor,zv10m_cor, & ! pour corriger d'un bug
     123       zrh2m_cor,zqsat2m_cor, &
    119124       zt2m_min_mon, zt2m_max_mon,   &         ! pour calcul_divers.h
    120125       t2m_min_mon, t2m_max_mon,  &            ! pour calcul_divers.h
    … …  
    170175       !    Deep convective variables used in phytrac
    171176       pmflxr, pmflxs,  &
    172        wdtrainA, wdtrainM,  &
     177       wdtrainA, wdtrainS, wdtrainM,  &
    173178       upwd, dnwd, &
    174179       ep,  &
    … …  
    180185       ev, &
    181186       elij, &
     187       qtaa, &
    182188       clw, &
    183189       epmlmMm, eplaMm, &
    … …  
    243249#endif
    244250    USE indice_sol_mod
    245     USE phytrac_mod, ONLY : phytrac
    246     USE carbon_cycle_mod, ONLY : infocfields_init
     251    USE phytrac_mod, ONLY : phytrac_init, phytrac
     252    USE carbon_cycle_mod, ONLY : infocfields_init, RCO2_glo, carbon_cycle_rad
    247253
    248254#ifdef CPP_RRTM
    … …  
    265271    USE ACAMA_GWD_rando_m, only: ACAMA_GWD_rando
    266272    USE VERTICAL_LAYERS_MOD, ONLY: aps,bps
     273    USE etat0_limit_unstruct_mod
     274#ifdef CPP_XIOS
     275    USE xios, ONLY: xios_update_calendar, xios_context_finalize
     276#endif
     277    USE limit_read_mod, ONLY : init_limit_read
     278    USE regr_horiz_time_climoz_m, ONLY: regr_horiz_time_climoz
     279    USE readaerosol_mod, ONLY : init_aero_fromfile
     280    USE readaerosolstrato_m, ONLY : init_readaerosolstrato
    267281
    268282    IMPLICIT NONE
    … …  
    323337    include "dimpft.h"
    324338    !======================================================================
     339    LOGICAL, SAVE :: ok_volcan ! pour activer les diagnostics volcaniques
     340    !$OMP THREADPRIVATE(ok_volcan)
    325341    LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
    326342    PARAMETER (ok_cvl=.TRUE.)
    327343    LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
    328344    PARAMETER (ok_gust=.FALSE.)
    329     integer iflag_radia     ! active ou non le rayonnement (MPL)
    330     save iflag_radia
     345    INTEGER, SAVE :: iflag_radia     ! active ou non le rayonnement (MPL)
    331346    !$OMP THREADPRIVATE(iflag_radia)
    332347    !======================================================================
    … …  
    363378    !======================================================================
    364379    LOGICAL ok_journe ! sortir le fichier journalier
    365     save ok_journe
     380    SAVE ok_journe
    366381    !$OMP THREADPRIVATE(ok_journe)
    367382    !
    368383    LOGICAL ok_mensuel ! sortir le fichier mensuel
    369     save ok_mensuel
     384    SAVE ok_mensuel
    370385    !$OMP THREADPRIVATE(ok_mensuel)
    371386    !
    372387    LOGICAL ok_instan ! sortir le fichier instantane
    373     save ok_instan
     388    SAVE ok_instan
    374389    !$OMP THREADPRIVATE(ok_instan)
    375390    !
    376391    LOGICAL ok_LES ! sortir le fichier LES
    377     save ok_LES                           
     392    SAVE ok_LES                           
    378393    !$OMP THREADPRIVATE(ok_LES)                 
    379394    !
    380395    LOGICAL callstats ! sortir le fichier stats
    381     save callstats                           
     396    SAVE callstats                           
    382397    !$OMP THREADPRIVATE(callstats)                 
    383398    !
    … …  
    385400    PARAMETER (ok_region=.FALSE.)
    386401    !======================================================================
    387     real seuil_inversion
    388     save seuil_inversion
     402    REAL seuil_inversion
     403    SAVE seuil_inversion
    389404    !$OMP THREADPRIVATE(seuil_inversion)
    390     integer iflag_ratqs
    391     save iflag_ratqs
     405    INTEGER iflag_ratqs
     406    SAVE iflag_ratqs
    392407    !$OMP THREADPRIVATE(iflag_ratqs)
    393408    real facteur
    … …  
    396411    REAL tau_overturning_th(klon)
    397412
    398     integer lmax_th(klon)
    399     integer limbas(klon)
    400     real ratqscth(klon,klev)
    401     real ratqsdiff(klon,klev)
    402     real zqsatth(klon,klev)
     413    INTEGER lmax_th(klon)
     414    INTEGER limbas(klon)
     415    REAL ratqscth(klon,klev)
     416    REAL ratqsdiff(klon,klev)
     417    REAL zqsatth(klon,klev)
    403418
    404419    !======================================================================
    … …  
    497512    CHARACTER*3 region
    498513    PARAMETER(region='3d')
    499     logical ok_hf
    500     !
    501     save ok_hf
     514    LOGICAL ok_hf
     515    !
     516    SAVE ok_hf
    502517    !$OMP THREADPRIVATE(ok_hf)
    503518
    504     INTEGER,PARAMETER :: longcles=20
    505     REAL,SAVE :: clesphy0(longcles)
     519    INTEGER, PARAMETER :: longcles=20
     520    REAL, SAVE :: clesphy0(longcles)
    506521    !$OMP THREADPRIVATE(clesphy0)
    507522    !
    508523    ! Variables propres a la physique
    509     INTEGER itap
    510     SAVE itap                   ! compteur pour la physique
     524    INTEGER, SAVE :: itap         ! compteur pour la physique
    511525    !$OMP THREADPRIVATE(itap)
    512526
    … …  
    514528    !$OMP THREADPRIVATE(abortphy)
    515529    !
    516     REAL,save ::  solarlong0
     530    REAL,SAVE ::  solarlong0
    517531    !$OMP THREADPRIVATE(solarlong0)
    518532
    … …  
    531545    ! Variables liees a la convection de K. Emanuel (sb):
    532546    !
    533     REAL bas, top             ! cloud base and top levels
    534     SAVE bas
    535     SAVE top
     547    REAL, SAVE :: bas, top             ! cloud base and top levels
    536548    !$OMP THREADPRIVATE(bas, top)
    537549    !------------------------------------------------------------------
    … …  
    551563    ! Variables li\'ees \`a la poche froide (jyg)
    552564
    553     REAL mip(klon,klev)  ! mass flux shed by the adiab ascent at each level
     565!!    REAL mipsh(klon,klev)  ! mass flux shed by the adiab ascent at each level
     566!!      Moved to phys_state_var_mod
    554567    !
    555568    REAL wape_prescr, fip_prescr
    … …  
    568581!!    REAL, DIMENSION(klon,klev)     :: dql_sat
    569582
    570     real, save :: alp_bl_prescr=0.
    571     real, save :: ale_bl_prescr=0.
    572 
    573     real, save :: wake_s_min_lsp=0.1
    574 
     583    REAL, SAVE :: alp_bl_prescr=0.
     584    REAL, SAVE :: ale_bl_prescr=0.
     585    REAL, SAVE :: wake_s_min_lsp=0.1
    575586    !$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr)
    576587    !$OMP THREADPRIVATE(wake_s_min_lsp)
    577588
    578 
    579     real ok_wk_lsp(klon)
     589    REAL ok_wk_lsp(klon)
    580590
    581591    !RC
    … …  
    590600                                                        ! gust-front in the grid cell.
    591601    !$OMP THREADPRIVATE(iflag_alp_wk_cond)
     602
     603    INTEGER,  SAVE               :: iflag_bug_t2m_ipslcm61=1 !
     604    !$OMP THREADPRIVATE(iflag_bug_t2m_ipslcm61)
     605    INTEGER,  SAVE               :: iflag_bug_t2m_stab_ipslcm61=-1 !
     606    !$OMP THREADPRIVATE(iflag_bug_t2m_stab_ipslcm61)
     607
    592608    REAL t_w(klon,klev),q_w(klon,klev) ! temperature and moisture profiles in the wake region
    593609    REAL t_x(klon,klev),q_x(klon,klev) ! temperature and moisture profiles in the off-wake region
    … …  
    727743    REAL :: jD_eq
    728744
    729     LOGICAL, parameter :: new_orbit = .true.
     745    LOGICAL, parameter :: new_orbit = .TRUE.
    730746
    731747    !
    … …  
    913929    INTEGER kcbot(klon), kctop(klon), kdtop(klon)
    914930    !
    915     real ratqsbas,ratqshaut,tau_ratqs
    916     save ratqsbas,ratqshaut,tau_ratqs
     931    REAL ratqsbas,ratqshaut,tau_ratqs
     932    SAVE ratqsbas,ratqshaut,tau_ratqs
    917933    !$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs)
    918934    REAL, SAVE :: ratqsp0=50000., ratqsdp=20000.
    … …  
    920936
    921937    ! Parametres lies au nouveau schema de nuages (SB, PDF)
    922     real fact_cldcon
    923     real facttemps
    924     logical ok_newmicro
    925     save ok_newmicro
     938    REAL, SAVE :: fact_cldcon
     939    REAL, SAVE :: facttemps
     940    !$OMP THREADPRIVATE(fact_cldcon,facttemps)
     941    LOGICAL, SAVE :: ok_newmicro
    926942    !$OMP THREADPRIVATE(ok_newmicro)
    927     !real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev)
    928     save fact_cldcon,facttemps
    929     !$OMP THREADPRIVATE(fact_cldcon,facttemps)
    930 
    931     integer iflag_cld_th
    932     save iflag_cld_th
     943
     944    INTEGER, SAVE :: iflag_cld_th
    933945    !$OMP THREADPRIVATE(iflag_cld_th)
    934946!IM logical ptconv(klon,klev)  !passe dans phys_local_var_mod
    935947    !IM cf. AM 081204 BEG
    936     logical ptconvth(klon,klev)
     948    LOGICAL ptconvth(klon,klev)
    937949    !IM cf. AM 081204 END
    938950    !
    … …  
    941953    !======================================================================
    942954    !
    943 
    944955    !
    945956!JLD    integer itau_w   ! pas de temps ecriture = itap + itau_phy
    … …  
    10071018!JLD    REAL zstophy, zout
    10081019
    1009     character*20 modname
    1010     character*80 abort_message
    1011     logical, save ::  ok_sync, ok_sync_omp
     1020    CHARACTER*20 modname
     1021    CHARACTER*80 abort_message
     1022    LOGICAL, SAVE ::  ok_sync, ok_sync_omp
    10121023    !$OMP THREADPRIVATE(ok_sync)
    1013     real date0
     1024    REAL date0
    10141025
    10151026    ! essai writephys
    1016     integer fid_day, fid_mth, fid_ins
    1017     parameter (fid_ins = 1, fid_day = 2, fid_mth = 3)
    1018     integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
    1019     parameter (prof2d_on = 1, prof3d_on = 2, &
    1020          prof2d_av = 3, prof3d_av = 4)
     1027    INTEGER fid_day, fid_mth, fid_ins
     1028    PARAMETER (fid_ins = 1, fid_day = 2, fid_mth = 3)
     1029    INTEGER prof2d_on, prof3d_on, prof2d_av, prof3d_av
     1030    PARAMETER (prof2d_on = 1, prof3d_on = 2, prof2d_av = 3, prof3d_av = 4)
    10211031    REAL ztsol(klon)
    10221032    REAL q2m(klon,nbsrf)  ! humidite a 2m
    … …  
    10701080    ! Declaration des constantes et des fonctions thermodynamiques
    10711081    !
    1072     LOGICAL,SAVE :: first=.true.
     1082    LOGICAL,SAVE :: first=.TRUE.
    10731083    !$OMP THREADPRIVATE(first)
    10741084
    … …  
    11061116    ! Declarations pour Simulateur COSP
    11071117    !============================================================
    1108     real :: mr_ozone(klon,klev)
     1118    real :: mr_ozone(klon,klev), phicosp(klon,klev)
    11091119
    11101120    !IM stations CFMIP
    … …  
    11641174    REAL zzz
    11651175    !albedo SB >>>
    1166     real,dimension(6),save :: SFRWL
     1176    REAL,DIMENSION(6), SAVE :: SFRWL
     1177!$OMP THREADPRIVATE(SFRWL)
    11671178    !albedo SB <<<
    11681179
    11691180    !--OB variables for mass fixer (hard coded for now)
    1170     logical, parameter :: mass_fixer=.false.
    1171     real qql1(klon),qql2(klon),corrqql
     1181    LOGICAL, PARAMETER :: mass_fixer=.FALSE.
     1182    REAL qql1(klon),qql2(klon),corrqql
    11721183
    11731184    REAL pi
    … …  
    11831194    pdtphys=pdtphys_
    11841195    CALL update_time(pdtphys)
     1196    phys_tstep=NINT(pdtphys)
     1197#ifdef CPP_XIOS
     1198    IF (.NOT. debut .AND. is_omp_master) CALL xios_update_calendar(itap+1)
     1199#endif
    11851200
    11861201    !======================================================================
    … …  
    12111226
    12121227    ! Quick check on pressure levels:
    1213     call assert(paprs(:, nbp_lev + 1) < paprs(:, nbp_lev), &
     1228    CALL assert(paprs(:, nbp_lev + 1) < paprs(:, nbp_lev), &
    12141229            "physiq_mod paprs bad order")
    12151230
    12161231    IF (first) THEN
     1232       CALL init_etat0_limit_unstruct
     1233       IF (.NOT. create_etat0_limit) CALL init_limit_read(days_elapsed)
    12171234       !CR:nvelles variables convection/poches froides
    12181235
    1219        print*, '================================================='
    1220        print*, 'Allocation des variables locales et sauvegardees'
     1236       WRITE(lunout,*) '================================================='
     1237       WRITE(lunout,*) 'Allocation des variables locales et sauvegardees'
     1238       WRITE(lunout,*) '================================================='
    12211239       CALL phys_local_var_init
    12221240       !
    1223        pasphys=pdtphys
    12241241       !     appel a la lecture du run.def physique
    12251242       CALL conf_phys(ok_journe, ok_mensuel, &
    … …  
    12301247            fact_cldcon, facttemps,ok_newmicro,iflag_radia, &
    12311248            iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
    1232             ok_ade, ok_aie, ok_alw, ok_cdnc, aerosol_couple,  chemistry_couple, &
     1249            ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, aerosol_couple, &
     1250            chemistry_couple, &
    12331251            flag_aerosol, flag_aerosol_strat, flag_aer_feedback, new_aod, &
    12341252            flag_bc_internal_mixture, bl95_b0, bl95_b1, &
    … …  
    12391257       CALL phys_state_var_init(read_climoz)
    12401258       CALL phys_output_var_init
     1259       IF (read_climoz>=1 .AND. create_etat0_limit .AND. grid_type==unstructured) &
     1260          CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
     1261
     1262#ifdef CPP_StratAer
     1263       CALL strataer_init
     1264#endif
     1265
    12411266       print*, '================================================='
    12421267       !
    … …  
    12451270          WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', &
    12461271               '(H2Ov, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.'
    1247           STOP
     1272          abort_message='see above'
     1273          CALL abort_physic(modname,abort_message,1)
    12481274       ENDIF
    12491275
    … …  
    12581284
    12591285       itau_con=0
    1260        first=.false.
     1286       first=.FALSE.
    12611287
    12621288    ENDIF  ! first
    … …  
    12871313! secondes
    12881314       tau_gl=86400.*tau_gl
    1289        print*,'debut physiq_mod tau_gl=',tau_gl
     1315       WRITE(lunout,*) 'debut physiq_mod tau_gl=',tau_gl
     1316
     1317       iflag_bug_t2m_ipslcm61 = 1
     1318       CALL getin_p('iflag_bug_t2m_ipslcm61', iflag_bug_t2m_ipslcm61)
     1319       iflag_bug_t2m_stab_ipslcm61 = -1
     1320       CALL getin_p('iflag_bug_t2m_stab_ipslcm61', iflag_bug_t2m_stab_ipslcm61)
     1321
    12901322       CALL getin_p('iflag_alp_wk_cond', iflag_alp_wk_cond)
    12911323       CALL getin_p('random_notrig_max',random_notrig_max)
    … …  
    13181350       CALL getin_p('NVM',nvm_lmdz)
    13191351
     1352       WRITE(lunout,*) 'iflag_alp_wk_cond=',  iflag_alp_wk_cond
     1353       WRITE(lunout,*) 'random_ntrig_max=',   random_notrig_max
     1354       WRITE(lunout,*) 'ok_adjwk=',           ok_adjwk
     1355       WRITE(lunout,*) 'iflag_adjwk=',        iflag_adjwk
     1356       WRITE(lunout,*) 'qtcon_multistep_max=',dtcon_multistep_max
     1357       WRITE(lunout,*) 'qdcon_multistep_max=',dqcon_multistep_max
     1358       WRITE(lunout,*) 'ratqsp0=',            ratqsp0
     1359       WRITE(lunout,*) 'ratqsdp=',            ratqsdp
     1360       WRITE(lunout,*) 'iflag_wake_tend=',    iflag_wake_tend
     1361       WRITE(lunout,*) 'ok_bad_ecmwf_thermo=',ok_bad_ecmwf_thermo
     1362       WRITE(lunout,*) 'ok_bug_cv_trac=',     ok_bug_cv_trac
     1363       WRITE(lunout,*) 'ok_bug_split_th=',    ok_bug_split_th
     1364       WRITE(lunout,*) 'fl_ebil=',            fl_ebil
     1365       WRITE(lunout,*) 'fl_cor_ebil=',        fl_cor_ebil
     1366       WRITE(lunout,*) 'iflag_phytrac=',      iflag_phytrac
     1367       WRITE(lunout,*) 'NVM=',                nvm_lmdz
     1368
    13201369       !--PC: defining fields to be exchanged between LMDz, ORCHIDEE and NEMO
    13211370       WRITE(lunout,*) 'Call to infocfields from physiq'
    … …  
    13691418       ENDIF
    13701419
     1420       tau_aero(:,:,:,:) = 1.e-15
     1421       piz_aero(:,:,:,:) = 1.
     1422       cg_aero(:,:,:,:)  = 0.
     1423
    13711424       IF (aerosol_couple .AND. (config_inca /= "aero" &
    13721425            .AND. config_inca /= "aeNP ")) THEN
    … …  
    13761429          CALL abort_physic (modname,abort_message,1)
    13771430       ENDIF
    1378 
    1379 
    13801431
    13811432       rnebcon0(:,:) = 0.0
    … …  
    14171468       ! pour obtenir le meme resultat.
    14181469!jyg for fh<
    1419 !!       dtime=pdtphys
    1420        dtime=NINT(pdtphys)
    1421        WRITE(lunout,*) 'Pas de temps dtime pdtphys ',dtime,pdtphys
    1422        IF (abs(dtime-pdtphys)>1.e-10) THEN
     1470       WRITE(lunout,*) 'Pas de temps phys_tstep pdtphys ',phys_tstep,pdtphys
     1471       IF (abs(phys_tstep-pdtphys)>1.e-10) THEN
    14231472          abort_message='pas de temps doit etre entier en seconde pour orchidee et XIOS'
    14241473          CALL abort_physic(modname,abort_message,1)
    14251474       ENDIF
    14261475!>jyg
    1427        IF (MOD(NINT(86400./dtime),nbapp_rad).EQ.0) THEN
    1428           radpas = NINT( 86400./dtime)/nbapp_rad
     1476       IF (MOD(NINT(86400./phys_tstep),nbapp_rad).EQ.0) THEN
     1477          radpas = NINT( 86400./phys_tstep)/nbapp_rad
    14291478       ELSE
    14301479          WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', &
    … …  
    14361485          CALL abort_physic(modname,abort_message,1)
    14371486       ENDIF
    1438        IF (nbapp_cv .EQ. 0) nbapp_cv=86400./dtime
    1439        IF (nbapp_wk .EQ. 0) nbapp_wk=86400./dtime
     1487       IF (nbapp_cv .EQ. 0) nbapp_cv=86400./phys_tstep
     1488       IF (nbapp_wk .EQ. 0) nbapp_wk=86400./phys_tstep
    14401489       print *,'physiq, nbapp_cv, nbapp_wk ',nbapp_cv,nbapp_wk
    1441        IF (MOD(NINT(86400./dtime),nbapp_cv).EQ.0) THEN
    1442           cvpas_0 = NINT( 86400./dtime)/nbapp_cv
     1490       IF (MOD(NINT(86400./phys_tstep),nbapp_cv).EQ.0) THEN
     1491          cvpas_0 = NINT( 86400./phys_tstep)/nbapp_cv
    14431492          cvpas = cvpas_0
    14441493       print *,'physiq, cvpas ',cvpas
    … …  
    14501499          abort_message='nbre de pas de temps physique n est pas multiple ' &
    14511500               // 'de nbapp_cv'
    1452           call abort_physic(modname,abort_message,1)
    1453        ENDIF
    1454        IF (MOD(NINT(86400./dtime),nbapp_wk).EQ.0) THEN
    1455           wkpas = NINT( 86400./dtime)/nbapp_wk
    1456        print *,'physiq, wkpas ',wkpas
     1501          CALL abort_physic(modname,abort_message,1)
     1502       ENDIF
     1503       IF (MOD(NINT(86400./phys_tstep),nbapp_wk).EQ.0) THEN
     1504          wkpas = NINT( 86400./phys_tstep)/nbapp_wk
     1505!       print *,'physiq, wkpas ',wkpas
    14571506       ELSE
    14581507          WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', &
    … …  
    14621511          abort_message='nbre de pas de temps physique n est pas multiple ' &
    14631512               // 'de nbapp_wk'
    1464           call abort_physic(modname,abort_message,1)
     1513          CALL abort_physic(modname,abort_message,1)
    14651514       ENDIF
    14661515       ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1467 
     1516       CALL init_iophy_new(latitude_deg,longitude_deg)
     1517
     1518          !===================================================================
     1519          !IM stations CFMIP
     1520          nCFMIP=npCFMIP
     1521          OPEN(98,file='npCFMIP_param.data',status='old', &
     1522               form='formatted',iostat=iostat)
     1523          IF (iostat == 0) THEN
     1524             READ(98,*,end=998) nCFMIP
     1525998          CONTINUE
     1526             CLOSE(98)
     1527             CONTINUE
     1528             IF(nCFMIP.GT.npCFMIP) THEN
     1529                print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler'
     1530                CALL abort_physic("physiq", "", 1)
     1531             ELSE
     1532                print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP
     1533             ENDIF
     1534
     1535             !
     1536             ALLOCATE(tabCFMIP(nCFMIP))
     1537             ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP))
     1538             ALLOCATE(tabijGCM(nCFMIP))
     1539             ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP))
     1540             ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP))
     1541             !
     1542             ! lecture des nCFMIP stations CFMIP, de leur numero
     1543             ! et des coordonnees geographiques lonCFMIP, latCFMIP
     1544             !
     1545             CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP,  &
     1546                  lonCFMIP, latCFMIP)
     1547             !
     1548             ! identification des
     1549             ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la
     1550             ! grille de LMDZ
     1551             ! 2) indices points tabijGCM de la grille physique 1d sur
     1552             ! klon points
     1553             ! 3) indices iGCM, jGCM de la grille physique 2d
     1554             !
     1555             CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, &
     1556                  tabijGCM, lonGCM, latGCM, iGCM, jGCM)
     1557             !
     1558          ELSE
     1559             ALLOCATE(tabijGCM(0))
     1560             ALLOCATE(lonGCM(0), latGCM(0))
     1561             ALLOCATE(iGCM(0), jGCM(0))
     1562          ENDIF
     1563
     1564#ifdef CPP_IOIPSL
     1565
     1566       !$OMP MASTER
     1567       ! FH : if ok_sync=.true. , the time axis is written at each time step
     1568       ! in the output files. Only at the end in the opposite case
     1569       ok_sync_omp=.FALSE.
     1570       CALL getin('ok_sync',ok_sync_omp)
     1571       CALL phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, &
     1572            iGCM,jGCM,lonGCM,latGCM, &
     1573            jjmp1,nlevSTD,clevSTD,rlevSTD, phys_tstep,ok_veget, &
     1574            type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, &
     1575            ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, &
     1576            read_climoz, phys_out_filestations, &
     1577            new_aod, aerosol_couple, &
     1578            flag_aerosol_strat, pdtphys, paprs, pphis,  &
     1579            pplay, lmax_th, ptconv, ptconvth, ivap,  &
     1580            d_u, d_t, qx, d_qx, zmasse, ok_sync_omp)
     1581       !$OMP END MASTER
     1582       !$OMP BARRIER
     1583       ok_sync=ok_sync_omp
     1584
     1585       freq_outNMC(1) = ecrit_files(7)
     1586       freq_outNMC(2) = ecrit_files(8)
     1587       freq_outNMC(3) = ecrit_files(9)
     1588       WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1)
     1589       WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2)
     1590       WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3)
     1591
     1592#ifndef CPP_XIOS
     1593       CALL ini_paramLMDZ_phy(phys_tstep,nid_ctesGCM)
     1594#endif
     1595
     1596#endif
     1597       ecrit_reg = ecrit_reg * un_jour
     1598       ecrit_tra = ecrit_tra * un_jour
     1599
     1600       !XXXPB Positionner date0 pour initialisation de ORCHIDEE
     1601       date0 = jD_ref
     1602       WRITE(*,*) 'physiq date0 : ',date0
     1603       !
     1604
     1605!       CALL create_climoz(read_climoz)
     1606      IF (.NOT. create_etat0_limit) CALL init_aero_fromfile(flag_aerosol)  !! initialise aero from file for XIOS interpolation (unstructured_grid)
     1607      IF (.NOT. create_etat0_limit) CALL init_readaerosolstrato(flag_aerosol_strat)  !! initialise aero strato from file for XIOS interpolation (unstructured_grid)
     1608
     1609#ifdef CPP_COSP
     1610      IF (ok_cosp) THEN
     1611           DO k = 1, klev
     1612             DO i = 1, klon
     1613               phicosp(i,k) = pphi(i,k) + pphis(i)
     1614             ENDDO
     1615           ENDDO
     1616        CALL phys_cosp(itap,phys_tstep,freq_cosp, &
     1617               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
     1618               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
     1619               klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
     1620               JrNt,ref_liq,ref_ice, &
     1621               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
     1622               zu10m,zv10m,pphis, &
     1623               zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
     1624               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
     1625               prfl(:,1:klev),psfl(:,1:klev), &
     1626               pmflxr(:,1:klev),pmflxs(:,1:klev), &
     1627               mr_ozone,cldtau, cldemi)
     1628      ENDIF
     1629#endif
     1630
     1631#ifdef CPP_COSP2
     1632        IF (ok_cosp) THEN
     1633           DO k = 1, klev
     1634             DO i = 1, klon
     1635               phicosp(i,k) = pphi(i,k) + pphis(i)
     1636             ENDDO
     1637           ENDDO
     1638          CALL phys_cosp2(itap,phys_tstep,freq_cosp, &
     1639               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
     1640               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
     1641               klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
     1642               JrNt,ref_liq,ref_ice, &
     1643               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
     1644               zu10m,zv10m,pphis, &
     1645               zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
     1646               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
     1647               prfl(:,1:klev),psfl(:,1:klev), &
     1648               pmflxr(:,1:klev),pmflxs(:,1:klev), &
     1649               mr_ozone,cldtau, cldemi)
     1650       ENDIF
     1651#endif
     1652
     1653#ifdef CPP_COSPV2
     1654        IF (ok_cosp) THEN
     1655           DO k = 1, klev
     1656             DO i = 1, klon
     1657               phicosp(i,k) = pphi(i,k) + pphis(i)
     1658             ENDDO
     1659           ENDDO
     1660          CALL lmdz_cosp_interface(itap,phys_tstep,freq_cosp, &
     1661               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
     1662               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
     1663               klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
     1664               JrNt,ref_liq,ref_ice, &
     1665               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
     1666               zu10m,zv10m,pphis, &
     1667               phicosp,paprs(:,1:klev),pplay,zxtsol,t_seri, &
     1668               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
     1669               prfl(:,1:klev),psfl(:,1:klev), &
     1670               pmflxr(:,1:klev),pmflxs(:,1:klev), &
     1671               mr_ozone,cldtau, cldemi)
     1672       ENDIF
     1673#endif
     1674
     1675       !
     1676       !
     1677!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1678       ! Nouvelle initialisation pour le rayonnement RRTM
     1679       !
     1680!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1681
     1682       CALL iniradia(klon,klev,paprs(1,1:klev+1))
     1683       ! Initialisation des champs dans phytrac qui sont utilisés par phys_output_write
     1684       IF (iflag_phytrac == 1 ) THEN
     1685          CALL phytrac_init()
     1686        ENDIF
     1687
     1688       CALL phys_output_write(itap, pdtphys, paprs, pphis,                    &
     1689                              pplay, lmax_th, aerosol_couple,                 &
     1690                              ok_ade, ok_aie, ok_volcan, ivap, iliq, isol, new_aod, ok_sync,&
     1691                              ptconv, read_climoz, clevSTD,                   &
     1692                              ptconvth, d_u, d_t, qx, d_qx, zmasse,           &
     1693                              flag_aerosol, flag_aerosol_strat, ok_cdnc)
     1694
     1695#ifdef CPP_XIOS
     1696       IF (is_omp_master) CALL xios_update_calendar(1)
     1697#endif
     1698       IF(read_climoz>=1 .AND. create_etat0_limit) CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
     1699       CALL create_etat0_limit_unstruct
    14681700       CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0)
     1701
    14691702!jyg<
    1470        IF (klon_glo==1) THEN
    1471           IF (iflag_pbl > 1) THEN         
    1472               pbl_tke(:,:,is_ave) = 0.
    1473               DO nsrf=1,nbsrf
    1474                 DO k = 1,klev+1
    1475                      pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) &
    1476                          +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
    1477                 ENDDO
    1478               ENDDO
    1479           ELSE   ! (iflag_pbl > 1)
    1480               pbl_tke(:,:,:) = 0.
    1481           ENDIF  ! (iflag_pbl > 1)
     1703       IF (iflag_pbl<=1) THEN
     1704          ! No TKE for Standard Physics
     1705          pbl_tke(:,:,:)=0.
     1706
     1707       ELSE IF (klon_glo==1) THEN
     1708          pbl_tke(:,:,is_ave) = 0.
     1709          DO nsrf=1,nbsrf
     1710            DO k = 1,klev+1
     1711                 pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) &
     1712                     +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
     1713            ENDDO
     1714          ENDDO
     1715        ELSE
     1716          pbl_tke(:,:,is_ave) = 0. !ym missing init : maybe must be initialized in the same way that for klon_glo==1 ??
    14821717!>jyg
    14831718       ENDIF
    … …  
    14961731       ENDIF
    14971732
    1498        CALL printflag( tabcntr0,radpas,ok_journe, &
    1499             ok_instan, ok_region )
    1500        !
    1501        IF (ABS(dtime-pdtphys).GT.0.001) THEN
    1502           WRITE(lunout,*) 'Pas physique n est pas correct',dtime, &
    1503                pdtphys
    1504           abort_message='Pas physique n est pas correct '
    1505           !           call abort_physic(modname,abort_message,1)
    1506           dtime=pdtphys
    1507        ENDIF
     1733!       IF (ABS(phys_tstep-pdtphys).GT.0.001) THEN
     1734!          WRITE(lunout,*) 'Pas physique n est pas correct',phys_tstep, &
     1735!               pdtphys
     1736!          abort_message='Pas physique n est pas correct '
     1737!          !           call abort_physic(modname,abort_message,1)
     1738!          phys_tstep=pdtphys
     1739!       ENDIF
    15081740       IF (nlon .NE. klon) THEN
    15091741          WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon,  &
    … …  
    15191751       ENDIF
    15201752       !
    1521        IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN
     1753       IF (phys_tstep*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN
    15221754          WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
    15231755          WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
    … …  
    15811813          !        enddo
    15821814
    1583           !===================================================================
    1584           !IM stations CFMIP
    1585           nCFMIP=npCFMIP
    1586           OPEN(98,file='npCFMIP_param.data',status='old', &
    1587                form='formatted',iostat=iostat)
    1588           IF (iostat == 0) THEN
    1589              READ(98,*,end=998) nCFMIP
    1590 998          CONTINUE
    1591              CLOSE(98)
    1592              CONTINUE
    1593              IF(nCFMIP.GT.npCFMIP) THEN
    1594                 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler'
    1595                 CALL abort_physic("physiq", "", 1)
    1596              ELSE
    1597                 print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP
    1598              ENDIF
    1599 
    1600              !
    1601              ALLOCATE(tabCFMIP(nCFMIP))
    1602              ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP))
    1603              ALLOCATE(tabijGCM(nCFMIP))
    1604              ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP))
    1605              ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP))
    1606              !
    1607              ! lecture des nCFMIP stations CFMIP, de leur numero
    1608              ! et des coordonnees geographiques lonCFMIP, latCFMIP
    1609              !
    1610              CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP,  &
    1611                   lonCFMIP, latCFMIP)
    1612              !
    1613              ! identification des
    1614              ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la
    1615              ! grille de LMDZ
    1616              ! 2) indices points tabijGCM de la grille physique 1d sur
    1617              ! klon points
    1618              ! 3) indices iGCM, jGCM de la grille physique 2d
    1619              !
    1620              CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, &
    1621                   tabijGCM, lonGCM, latGCM, iGCM, jGCM)
    1622              !
    1623           ELSE
    1624              ALLOCATE(tabijGCM(0))
    1625              ALLOCATE(lonGCM(0), latGCM(0))
    1626              ALLOCATE(iGCM(0), jGCM(0))
    1627           ENDIF
    1628        ELSE
    1629           ALLOCATE(tabijGCM(0))
    1630           ALLOCATE(lonGCM(0), latGCM(0))
    1631           ALLOCATE(iGCM(0), jGCM(0))
     1815       !ELSE
     1816       !   ALLOCATE(tabijGCM(0))
     1817       !   ALLOCATE(lonGCM(0), latGCM(0))
     1818       !   ALLOCATE(iGCM(0), jGCM(0))
    16321819       ENDIF
    16331820
    … …  
    16651852       !
    16661853       !
    1667        lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
     1854       lmt_pas = NINT(86400./phys_tstep * 1.0)   ! tous les jours
    16681855       WRITE(lunout,*)'La frequence de lecture surface est de ',  &
    16691856            lmt_pas
    … …  
    16811868       !   Initialisation des sorties
    16821869       !=============================================================
     1870
     1871#ifdef CPP_XIOS
     1872       ! Get "missing_val" value from XML files (from temperature variable)
     1873       !$OMP MASTER
     1874       CALL xios_get_field_attr("temp",default_value=missing_val_omp)
     1875       !$OMP END MASTER
     1876       !$OMP BARRIER
     1877       missing_val=missing_val_omp
     1878#endif
    16831879
    16841880#ifdef CPP_XIOS
    … …  
    16931889#endif
    16941890
    1695 #ifdef CPP_IOIPSL
    1696 
    1697        !$OMP MASTER
    1698        ! FH : if ok_sync=.true. , the time axis is written at each time step
    1699        ! in the output files. Only at the end in the opposite case
    1700        ok_sync_omp=.false.
    1701        CALL getin('ok_sync',ok_sync_omp)
    1702        CALL phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, &
    1703             iGCM,jGCM,lonGCM,latGCM, &
    1704             jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, &
    1705             type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, &
    1706             ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, &
    1707             read_climoz, phys_out_filestations, &
    1708             new_aod, aerosol_couple, &
    1709             flag_aerosol_strat, pdtphys, paprs, pphis,  &
    1710             pplay, lmax_th, ptconv, ptconvth, ivap,  &
    1711             d_u, d_t, qx, d_qx, zmasse, ok_sync_omp)
    1712        !$OMP END MASTER
    1713        !$OMP BARRIER
    1714        ok_sync=ok_sync_omp
    1715 
    1716        freq_outNMC(1) = ecrit_files(7)
    1717        freq_outNMC(2) = ecrit_files(8)
    1718        freq_outNMC(3) = ecrit_files(9)
    1719        WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1)
    1720        WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2)
    1721        WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3)
    1722 
    1723 #ifndef CPP_XIOS
    1724        CALL ini_paramLMDZ_phy(dtime,nid_ctesGCM)
    1725 #endif
    1726 
    1727 #endif
    1728        ecrit_reg = ecrit_reg * un_jour
    1729        ecrit_tra = ecrit_tra * un_jour
    1730 
    1731        !XXXPB Positionner date0 pour initialisation de ORCHIDEE
    1732        date0 = jD_ref
    1733        WRITE(*,*) 'physiq date0 : ',date0
     1891
     1892       CALL printflag( tabcntr0,radpas,ok_journe, &
     1893            ok_instan, ok_region )
    17341894       !
    17351895       !
    … …  
    17921952#endif
    17931953       ENDIF
    1794        !
    1795        ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1796        ! Nouvelle initialisation pour le rayonnement RRTM
    1797        ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1798 
    1799        CALL iniradia(klon,klev,paprs(1,1:klev+1))
    18001954
    18011955       !$omp single
    … …  
    18151969
    18161970       !albedo SB >>>
    1817        select case(nsw)
    1818        case(2)
     1971       SELECT CASE(nsw)
     1972       CASE(2)
    18191973          SFRWL(1)=0.45538747
    18201974          SFRWL(2)=0.54461211
    1821        case(4)
     1975       CASE(4)
    18221976          SFRWL(1)=0.45538747
    18231977          SFRWL(2)=0.32870591
    18241978          SFRWL(3)=0.18568763
    18251979          SFRWL(4)=3.02191470E-02
    1826        case(6)
     1980       CASE(6)
    18271981          SFRWL(1)=1.28432794E-03
    18281982          SFRWL(2)=0.12304168
    … …  
    18311985          SFRWL(5)=0.18568763
    18321986          SFRWL(6)=3.02191470E-02
    1833        end select
     1987       END SELECT
    18341988
    18351989
    … …  
    18702024      sollwdown(:)= sollwdown(:) + betalwoff *(-1.*ZFLDN0(:,1) - &
    18712025                    sollwdown(:))
     2026
     2027
    18722028    ENDIF
    18732029    !
    … …  
    18912047    ! on the surface fraction.
    18922048    !
    1893     CALL change_srf_frac(itap, dtime, days_elapsed+1,  &
     2049    CALL change_srf_frac(itap, phys_tstep, days_elapsed+1,  &
    18942050         pctsrf, fevap, z0m, z0h, agesno,              &
    18952051         falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)
    … …  
    19032059#endif
    19042060    ENDIF
    1905 
    19062061
    19072062    ! Tendances bidons pour les processus qui n'affectent pas certaines
    … …  
    20052160       ENDDO
    20062161    ENDIF
     2162!
     2163! Temporary solutions adressing ticket #104 and the non initialisation of tr_ancien
     2164! LF
     2165    IF (debut) THEN
     2166      WRITE(lunout,*)' WARNING: tr_ancien initialised to tr_seri'
     2167      DO iq = nqo+1, nqtot
     2168           tr_ancien(:,:,iq-nqo)=tr_seri(:,:,iq-nqo)
     2169      ENDDO
     2170    ENDIF
    20072171    !
    20082172    DO i = 1, klon
    … …  
    20212185    IF (ancien_ok) THEN
    20222186    !
    2023        d_u_dyn(:,:)  = (u_seri(:,:)-u_ancien(:,:))/dtime
    2024        d_v_dyn(:,:)  = (v_seri(:,:)-v_ancien(:,:))/dtime
    2025        d_t_dyn(:,:)  = (t_seri(:,:)-t_ancien(:,:))/dtime
    2026        d_q_dyn(:,:)  = (q_seri(:,:)-q_ancien(:,:))/dtime
    2027        d_ql_dyn(:,:) = (ql_seri(:,:)-ql_ancien(:,:))/dtime
    2028        d_qs_dyn(:,:) = (qs_seri(:,:)-qs_ancien(:,:))/dtime
     2187       d_u_dyn(:,:)  = (u_seri(:,:)-u_ancien(:,:))/phys_tstep
     2188       d_v_dyn(:,:)  = (v_seri(:,:)-v_ancien(:,:))/phys_tstep
     2189       d_t_dyn(:,:)  = (t_seri(:,:)-t_ancien(:,:))/phys_tstep
     2190       d_q_dyn(:,:)  = (q_seri(:,:)-q_ancien(:,:))/phys_tstep
     2191       d_ql_dyn(:,:) = (ql_seri(:,:)-ql_ancien(:,:))/phys_tstep
     2192       d_qs_dyn(:,:) = (qs_seri(:,:)-qs_ancien(:,:))/phys_tstep
    20292193       CALL water_int(klon,klev,q_seri,zmasse,zx_tmp_fi2d)
    2030        d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/dtime
     2194       d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/phys_tstep
    20312195       CALL water_int(klon,klev,ql_seri,zmasse,zx_tmp_fi2d)
    2032        d_ql_dyn2d(:)=(zx_tmp_fi2d(:)-prlw_ancien(:))/dtime
     2196       d_ql_dyn2d(:)=(zx_tmp_fi2d(:)-prlw_ancien(:))/phys_tstep
    20332197       CALL water_int(klon,klev,qs_seri,zmasse,zx_tmp_fi2d)
    2034        d_qs_dyn2d(:)=(zx_tmp_fi2d(:)-prsw_ancien(:))/dtime
     2198       d_qs_dyn2d(:)=(zx_tmp_fi2d(:)-prsw_ancien(:))/phys_tstep
    20352199       ! !! RomP >>>   td dyn traceur
    20362200       IF (nqtot.GT.nqo) THEN     ! jyg
    20372201          DO iq = nqo+1, nqtot      ! jyg
    2038               d_tr_dyn(:,:,iq-nqo)=(tr_seri(:,:,iq-nqo)-tr_ancien(:,:,iq-nqo))/dtime ! jyg
     2202              d_tr_dyn(:,:,iq-nqo)=(tr_seri(:,:,iq-nqo)-tr_ancien(:,:,iq-nqo))/phys_tstep ! jyg
    20392203          ENDDO
    20402204       ENDIF
    … …  
    21382302                      ro3i, 'C', press_cen_climoz, pplay, wo, paprs(:,1),    &
    21392303                      time_climoz )
    2140           END IF
     2304          ENDIF
    21412305          ! Convert from mole fraction of ozone to column density of ozone in a
    21422306          ! cell, in kDU:
    … …  
    21582322            (du0,dv0,d_t_eva,d_q_eva,d_ql_eva,d_qi_eva,paprs,&
    21592323               'eva',abortphy,flag_inhib_tend,itap,0)
    2160     call prt_enerbil('eva',itap)
     2324    CALL prt_enerbil('eva',itap)
    21612325
    21622326    !=========================================================================
    … …  
    22132377          !  bit comparable a l ancienne formulation cycle_diurne=true
    22142378          !  on integre entre gmtime et gmtime+radpas
    2215           zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s)
     2379          zdtime=phys_tstep*REAL(radpas) ! pas de temps du rayonnement (s)
    22162380          CALL zenang(zlongi,jH_cur,0.0,zdtime, &
    22172381               latitude_deg,longitude_deg,rmu0,fract)
    … …  
    22302394          !  premier pas de temps de la physique pendant lequel
    22312395          !  itaprad=0
    2232           zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1)     
    2233           zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1)
     2396          zdtime1=phys_tstep*REAL(-MOD(itaprad,radpas)-1)     
     2397          zdtime2=phys_tstep*REAL(radpas-MOD(itaprad,radpas)-1)
    22342398          CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, &
    22352399               latitude_deg,longitude_deg,rmu0,fract)
    … …  
    22372401          ! Calcul des poids
    22382402          !
    2239           zdtime1=-dtime !--on corrige le rayonnement pour representer le
     2403          zdtime1=-phys_tstep !--on corrige le rayonnement pour representer le
    22402404          zdtime2=0.0    !--pas de temps de la physique qui se termine
    22412405          CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, &
    … …  
    22952459       !
    22962460       !-------gustiness calculation-------!
     2461       !ym : Warning gustiness non inialized for iflag_gusts=2 & iflag_gusts=3
     2462       gustiness=0  !ym missing init
     2463       
    22972464       IF (iflag_gusts==0) THEN
    22982465          gustiness(1:klon)=0
    … …  
    23122479       ENDIF
    23132480
    2314 
    2315 
    23162481       CALL pbl_surface(  &
    2317             dtime,     date0,     itap,    days_elapsed+1, &
     2482            phys_tstep,     date0,     itap,    days_elapsed+1, &
    23182483            debut,     lafin, &
    23192484            longitude_deg, latitude_deg, rugoro,  zrmu0,      &
    … …  
    23822547       ENDIF
    23832548
    2384 
    2385 
    2386 
     2549!add limitation for t,q at and wind at 10m
     2550        if ( iflag_bug_t2m_ipslcm61 == 0 ) THEN
     2551          CALL borne_var_surf( klon,klev,nbsrf,                 &
     2552            iflag_bug_t2m_stab_ipslcm61,                        &
     2553            t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),    &
     2554            ftsol,zxqsurf,pctsrf,paprs,                         &
     2555            t2m, q2m, u10m, v10m,                               &
     2556            zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor,           &
     2557            zrh2m_cor, zqsat2m_cor)
     2558        ELSE
     2559          zt2m_cor(:)=zt2m(:)
     2560          zq2m_cor(:)=zq2m(:)
     2561          zu10m_cor(:)=zu10m(:)
     2562          zv10m_cor(:)=zv10m(:)
     2563          zqsat2m_cor=999.999
     2564        ENDIF
    23872565
    23882566       !---------------------------------------------------------------------
    … …  
    23972575               'vdf',abortphy,flag_inhib_tend,itap,0)
    23982576       ENDIF
    2399        call prt_enerbil('vdf',itap)
     2577       CALL prt_enerbil('vdf',itap)
    24002578       !--------------------------------------------------------------------
    24012579
    … …  
    24822660       DO i = 1, klon
    24832661          conv_q(i,k) = d_q_dyn(i,k)  &
    2484                + d_q_vdf(i,k)/dtime
     2662               + d_q_vdf(i,k)/phys_tstep
    24852663          conv_t(i,k) = d_t_dyn(i,k)  &
    2486                + d_t_vdf(i,k)/dtime
     2664               + d_t_vdf(i,k)/phys_tstep
    24872665       ENDDO
    24882666    ENDDO
    … …  
    25282706    pmflxs(:,:) = 0.
    25292707    wdtrainA(:,:) = 0.
     2708    wdtrainS(:,:) = 0.
    25302709    wdtrainM(:,:) = 0.
    25312710    upwd(:,:) = 0.
    … …  
    25432722    elij(:,:,:)=0.
    25442723    ev(:,:)=0.
     2724    qtaa(:,:)=0.
    25452725    clw(:,:)=0.
    25462726    sij(:,:,:)=0.
    … …  
    25492729       abort_message ='reactiver le call conlmd dans physiq.F'
    25502730       CALL abort_physic (modname,abort_message,1)
    2551        !     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
     2731       !     CALL conlmd (phys_tstep, paprs, pplay, t_seri, q_seri, conv_q,
    25522732       !    .             d_t_con, d_q_con,
    25532733       !    .             rain_con, snow_con, ibas_con, itop_con)
    25542734    ELSE IF (iflag_con.EQ.2) THEN
    2555        CALL conflx(dtime, paprs, pplay, t_seri, q_seri, &
     2735       CALL conflx(phys_tstep, paprs, pplay, t_seri, q_seri, &
    25562736            conv_t, conv_q, -evap, omega, &
    25572737            d_t_con, d_q_con, rain_con, snow_con, &
    … …  
    26292809
    26302810!jyg<
    2631        CALL alpale( debut, itap, dtime, paprs, omega, t_seri,   &
     2811       CALL alpale( debut, itap, phys_tstep, paprs, omega, t_seri,   &
    26322812                    alp_offset, it_wape_prescr,  wape_prescr, fip_prescr, &
    26332813                    ale_bl_prescr, alp_bl_prescr, &
    … …  
    26712851          !c          CALL concvl (iflag_con,iflag_clos,
    26722852          CALL concvl (iflag_clos, &
    2673                dtime, paprs, pplay, k_upper_cv, t_x,q_x, &
     2853               phys_tstep, paprs, pplay, k_upper_cv, t_x,q_x, &
    26742854               t_w,q_w,wake_s, &
    26752855               u_seri,v_seri,tr_seri,nbtr_tmp, &
    … …  
    26792859               rain_con, snow_con, ibas_con, itop_con, sigd, &
    26802860               ema_cbmf,plcl,plfc,wbeff,convoccur,upwd,dnwd,dnwd0, &
    2681                Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, &
     2861               Ma,mipsh,Vprecip,cape,cin,tvp,Tconv,iflagctrl, &
    26822862               pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, &
    26832863                                ! RomP >>>
    26842864                                !!     .        pmflxr,pmflxs,da,phi,mp,
    26852865                                !!     .        ftd,fqd,lalim_conv,wght_th)
    2686                pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, &
     2866               pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,qtaa,clw,elij, &
    26872867               ftd,fqd,lalim_conv,wght_th, &
    26882868               ev, ep,epmlmMm,eplaMm, &
    2689                wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, &
     2869               wdtrainA, wdtrainS, wdtrainM,wght_cvfd,qtc_cv,sigt_cv, &
    26902870               tau_cld_cv,coefw_cld_cv,epmax_diag)
    26912871
    … …  
    27412921              DO k=1,klev
    27422922                 DO i=1,klon
    2743                     ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime
    2744                     fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime
     2923                    ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/phys_tstep
     2924                    fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/phys_tstep
    27452925                    d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k)
    27462926                    d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k)
    … …  
    27542934
    27552935          ! MAF conema3 ne contient pas les traceurs
    2756           CALL conema3 (dtime, &
     2936          CALL conema3 (phys_tstep, &
    27572937               paprs,pplay,t_seri,q_seri, &
    27582938               u_seri,v_seri,tr_seri,ntra, &
    … …  
    28653045    CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, &
    28663046         'convection',abortphy,flag_inhib_tend,itap,0)
    2867     call prt_enerbil('convection',itap)
     3047    CALL prt_enerbil('convection',itap)
    28683048
    28693049    !-------------------------------------------------------------------------
    … …  
    28863066               snow_con(i))*cell_area(i)/REAL(klon)
    28873067       ENDDO
    2888        zx_t = zx_t/za*dtime
     3068       zx_t = zx_t/za*phys_tstep
    28893069       WRITE(lunout,*)"Precip=", zx_t
    28903070    ENDIF
    … …  
    29003080       ENDDO
    29013081       DO i = 1, klon
    2902           z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) &
     3082          z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*phys_tstep) &
    29033083               /z_apres(i)
    29043084       ENDDO
    … …  
    29373117                M_dwn(i,k)   = dnwd0(i,k)
    29383118                M_up(i,k)    = upwd(i,k)
    2939                 dt_a(i,k)    = d_t_con(i,k)/dtime - ftd(i,k)
    2940                 dq_a(i,k)    = d_q_con(i,k)/dtime - fqd(i,k)
     3119                dt_a(i,k)    = d_t_con(i,k)/phys_tstep - ftd(i,k)
     3120                dq_a(i,k)    = d_q_con(i,k)/phys_tstep - fqd(i,k)
    29413121             ENDDO
    29423122          ENDDO
    … …  
    29463126             DO k = 1,klev
    29473127                dt_dwn(:,k)= dt_dwn(:,k)+ &
    2948                      ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime
     3128                     ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/phys_tstep
    29493129                dq_dwn(:,k)= dq_dwn(:,k)+ &
    2950                      ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime
     3130                     ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/phys_tstep
    29513131             ENDDO
    29523132          ELSEIF (iflag_wake==3) THEN
    … …  
    29593139                      ! l'eau se reevapore).
    29603140                      dt_dwn(i,k)= dt_dwn(i,k)+ &
    2961                            ok_wk_lsp(i)*d_t_lsc(i,k)/dtime
     3141                           ok_wk_lsp(i)*d_t_lsc(i,k)/phys_tstep
    29623142                      dq_dwn(i,k)= dq_dwn(i,k)+ &
    2963                            ok_wk_lsp(i)*d_q_lsc(i,k)/dtime
     3143                           ok_wk_lsp(i)*d_q_lsc(i,k)/phys_tstep
    29643144                   ENDIF
    29653145                ENDDO
    … …  
    29693149          !
    29703150          !calcul caracteristiques de la poche froide
    2971           CALL calWAKE (iflag_wake_tend, paprs, pplay, dtime, &
     3151          CALL calWAKE (iflag_wake_tend, paprs, pplay, phys_tstep, &
    29723152               t_seri, q_seri, omega,  &
    29733153               dt_dwn, dq_dwn, M_dwn, M_up,  &
    … …  
    29963176       CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake', &
    29973177            abortphy,flag_inhib_tend,itap,0)
    2998        call prt_enerbil('wake',itap)
     3178       CALL prt_enerbil('wake',itap)
    29993179       !------------------------------------------------------------------------
    30003180
    … …  
    30053185            (d_deltat_wk, d_deltaq_wk, d_s_wk, d_dens_a_wk, d_dens_wk, wake_k, &
    30063186             'wake', abortphy)
    3007           call prt_enerbil('wake',itap)
     3187          CALL prt_enerbil('wake',itap)
    30083188       ENDIF   ! (iflag_wake_tend .GT. 0.)
    30093189       !
    … …  
    30163196       IF (iflag_alp_wk_cond .GT. 0.) THEN
    30173197
    3018          CALL alpale_wk(dtime, cell_area, wake_k, wake_s, wake_dens, wake_fip_0, &
     3198         CALL alpale_wk(phys_tstep, cell_area, wake_k, wake_s, wake_dens, wake_fip_0, &
    30193199                        wake_fip)
    30203200       ELSE
    … …  
    31473327                   (d_deltat_the, d_deltaq_the, dsig0, ddens0, ddens0, wake_k, 'the', abortphy)
    31483328             ENDIF
    3149              call prt_enerbil('the',itap)
     3329             CALL prt_enerbil('the',itap)
    31503330          !
    31513331          ENDIF  ! (mod(iflag_pbl_split/10,10) .GE. 1)
    … …  
    31533333          CALL add_phys_tend(d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs,  &
    31543334                             dql0,dqi0,paprs,'thermals', abortphy,flag_inhib_tend,itap,0)
    3155           call prt_enerbil('thermals',itap)
     3335          CALL prt_enerbil('thermals',itap)
    31563336          !
    31573337!
    3158           CALL alpale_th( dtime, lmax_th, t_seri, cell_area,  &
     3338          CALL alpale_th( phys_tstep, lmax_th, t_seri, cell_area,  &
    31593339                          cin, s2, n2,  &
    31603340                          ale_bl_trig, ale_bl_stat, ale_bl,  &
    … …  
    32163396          CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs, &
    32173397               'ajsb',abortphy,flag_inhib_tend,itap,0)
    3218           call prt_enerbil('ajsb',itap)
     3398          CALL prt_enerbil('ajsb',itap)
    32193399          d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
    32203400          d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
    … …  
    32463426    ENDIF
    32473427    !
    3248     CALL fisrtilp(dtime,paprs,pplay, &
     3428    CALL fisrtilp(phys_tstep,paprs,pplay, &
    32493429         t_seri, q_seri,ptconv,ratqs, &
    32503430         d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, &
    … …  
    32673447    CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs, &
    32683448         'lsc',abortphy,flag_inhib_tend,itap,0)
    3269     call prt_enerbil('lsc',itap)
     3449    CALL prt_enerbil('lsc',itap)
    32703450    rain_num(:)=0.
    32713451    DO k = 1, klev
    … …  
    33063486               + snow_lsc(i))*cell_area(i)/REAL(klon)
    33073487       ENDDO
    3308        zx_t = zx_t/za*dtime
     3488       zx_t = zx_t/za*phys_tstep
    33093489       WRITE(lunout,*)"Precip=", zx_t
    33103490    ENDIF
    … …  
    35263706       calday = REAL(days_elapsed + 1) + jH_cur
    35273707
    3528        CALL chemtime(itap+itau_phy-1, date0, dtime, itap)
    3529        IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN
    3530           CALL AEROSOL_METEO_CALC( &
    3531                calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, &
    3532                prfl,psfl,pctsrf,cell_area, &
    3533                latitude_deg,longitude_deg,u10m,v10m)
    3534        ENDIF
     3708       CALL chemtime(itap+itau_phy-1, date0, phys_tstep, itap)
     3709       CALL AEROSOL_METEO_CALC( &
     3710            calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, &
     3711            prfl,psfl,pctsrf,cell_area, &
     3712            latitude_deg,longitude_deg,u10m,v10m)
    35353713
    35363714       zxsnow_dummy(:) = 0.0
    … …  
    36153793#else
    36163794                   !--climatologies or INCA aerosols
    3617                    CALL readaerosol_optic_rrtm( debut, aerosol_couple, ok_alw, &
     3795                   CALL readaerosol_optic_rrtm( debut, aerosol_couple, ok_alw, ok_volcan, &
    36183796                        new_aod, flag_aerosol, flag_bc_internal_mixture, itap, jD_cur-jD_ref, &
    36193797                        pdtphys, pplay, paprs, t_seri, rhcl, presnivs,  &
    … …  
    37053883             CALL readaerosolstrato1_rrtm(debut)
    37063884            ELSEIF (flag_aerosol_strat.EQ.2) THEN
    3707              CALL readaerosolstrato2_rrtm(debut)
     3885             CALL readaerosolstrato2_rrtm(debut, ok_volcan)
    37083886            ELSE
    37093887             abort_message='flag_aerosol_strat must equal 1 or 2 for rrtm=1'
    … …  
    37173895#endif
    37183896          ENDIF
     3897       ELSE
     3898          tausum_aero(:,:,id_STRAT_phy) = 0.
    37193899       ENDIF
    37203900!
    … …  
    38954075          RCFC11 = RCFC11_act
    38964076          RCFC12 = RCFC12_act
     4077          !
     4078          !--interactive CO2 in ppm from carbon cycle
     4079          IF (carbon_cycle_rad.AND..NOT.debut) THEN
     4080            RCO2=RCO2_glo
     4081          ENDIF
    38974082          !
    38984083          IF (prt_level .GE.10) THEN
    38994084             print *,' ->radlwsw, number 1 '
    39004085          ENDIF
    3901 
    39024086          !
    39034087          CALL radlwsw &
    … …  
    39094093               t_seri,q_seri,wo, &
    39104094               cldfrarad, cldemirad, cldtaurad, &
    3911                ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, &
     4095               ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie,  ok_volcan, &
     4096               flag_aerosol, &
    39124097               flag_aerosol_strat, flag_aer_feedback, &
    39134098               tau_aero, piz_aero, cg_aero, &
    … …  
    39204105               ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
    39214106               heat,heat0,cool,cool0,albpla, &
     4107               heat_volc,cool_volc, &
    39224108               topsw,toplw,solsw,sollw, &
    39234109               sollwdown, &
    … …  
    39944180                     t_seri,q_seri,wo, &
    39954181                     cldfrarad, cldemirad, cldtaurad, &
    3996                      ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, &
     4182                     ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie,  ok_volcan, &
     4183                     flag_aerosol, &
    39974184                     flag_aerosol_strat, flag_aer_feedback, &
    39984185                     tau_aero, piz_aero, cg_aero, &
    … …  
    40054192                     ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
    40064193                     heatp,heat0p,coolp,cool0p,albplap, &
     4194                     heat_volc,cool_volc, &
    40074195                     topswp,toplwp,solswp,sollwp, &
    40084196                     sollwdownp, &
    … …  
    40724260
    40734261    DO k=1, klev
    4074        d_t_swr(:,k)=swradcorr(:)*heat(:,k)*dtime/RDAY
    4075        d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*dtime/RDAY
    4076        d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY
    4077        d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY
     4262       d_t_swr(:,k)=swradcorr(:)*heat(:,k)*phys_tstep/RDAY
     4263       d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*phys_tstep/RDAY
     4264       d_t_lwr(:,k)=-cool(:,k)*phys_tstep/RDAY
     4265       d_t_lw0(:,k)=-cool0(:,k)*phys_tstep/RDAY
    40784266    ENDDO
    40794267
    40804268    CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy,flag_inhib_tend,itap,0)
    4081     call prt_enerbil('SW',itap)
     4269    CALL prt_enerbil('SW',itap)
    40824270    CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy,flag_inhib_tend,itap,0)
    4083     call prt_enerbil('LW',itap)
     4271    CALL prt_enerbil('LW',itap)
    40844272
    40854273    !
    … …  
    41314319       IF (ok_strato) THEN
    41324320
    4133           CALL drag_noro_strato(0,klon,klev,dtime,paprs,pplay, &
     4321          CALL drag_noro_strato(0,klon,klev,phys_tstep,paprs,pplay, &
    41344322               zmea,zstd, zsig, zgam, zthe,zpic,zval, &
    41354323               igwd,idx,itest, &
    … …  
    41394327
    41404328       ELSE
    4141           CALL drag_noro(klon,klev,dtime,paprs,pplay, &
     4329          CALL drag_noro(klon,klev,phys_tstep,paprs,pplay, &
    41424330               zmea,zstd, zsig, zgam, zthe,zpic,zval, &
    41434331               igwd,idx,itest, &
    … …  
    41524340       CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro', &
    41534341            abortphy,flag_inhib_tend,itap,0)
    4154        call prt_enerbil('oro',itap)
     4342       CALL prt_enerbil('oro',itap)
    41554343       !----------------------------------------------------------------------
    41564344       !
    … …  
    41804368       IF (ok_strato) THEN
    41814369
    4182           CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, &
     4370          CALL lift_noro_strato(klon,klev,phys_tstep,paprs,pplay, &
    41834371               latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, &
    41844372               igwd,idx,itest, &
    … …  
    41884376
    41894377       ELSE
    4190           CALL lift_noro(klon,klev,dtime,paprs,pplay, &
     4378          CALL lift_noro(klon,klev,phys_tstep,paprs,pplay, &
    41914379               latitude_deg,zmea,zstd,zpic, &
    41924380               itest, &
    … …  
    41994387       CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, &
    42004388            'lif', abortphy,flag_inhib_tend,itap,0)
    4201        call prt_enerbil('lif',itap)
     4389       CALL prt_enerbil('lif',itap)
    42024390    ENDIF ! fin de test sur ok_orolf
    42034391
    … …  
    42084396       du_gwd_hines=0.
    42094397       dv_gwd_hines=0.
    4210        CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, &
     4398       CALL hines_gwd(klon, klev, phys_tstep, paprs, pplay, latitude_deg, t_seri, &
    42114399            u_seri, v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, &
    42124400            du_gwd_hines, dv_gwd_hines)
    … …  
    42144402       zvstr_gwd_hines=0.
    42154403       DO k = 1, klev
    4216           zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime &
     4404          zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/phys_tstep &
    42174405               * (paprs(:, k)-paprs(:, k+1))/rg
    4218           zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime &
     4406          zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/phys_tstep &
    42194407               * (paprs(:, k)-paprs(:, k+1))/rg
    42204408       ENDDO
    … …  
    42234411       CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, &
    42244412            dqi0, paprs, 'hin', abortphy,flag_inhib_tend,itap,0)
    4225        call prt_enerbil('hin',itap)
     4413       CALL prt_enerbil('hin',itap)
    42264414    ENDIF
    42274415
    42284416    IF (.not. ok_hines .and. ok_gwd_rando) then
    4229        CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, &
     4417       ! ym missing init for east_gwstress & west_gwstress -> added in phys_local_var_mod
     4418       CALL acama_GWD_rando(PHYS_TSTEP, pplay, latitude_deg, t_seri, u_seri, &
    42304419            v_seri, rot, zustr_gwd_front, zvstr_gwd_front, du_gwd_front, &
    42314420            dv_gwd_front, east_gwstress, west_gwstress)
    … …  
    42334422       zvstr_gwd_front=0.
    42344423       DO k = 1, klev
    4235           zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime &
     4424          zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/phys_tstep &
    42364425               * (paprs(:, k)-paprs(:, k+1))/rg
    4237           zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime &
     4426          zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/phys_tstep &
    42384427               * (paprs(:, k)-paprs(:, k+1))/rg
    42394428       ENDDO
    … …  
    42414430       CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, &
    42424431            paprs, 'front_gwd_rando', abortphy,flag_inhib_tend,itap,0)
    4243        call prt_enerbil('front_gwd_rando',itap)
     4432       CALL prt_enerbil('front_gwd_rando',itap)
    42444433    ENDIF
    42454434
    42464435    IF (ok_gwd_rando) THEN
    4247        CALL FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, &
     4436       CALL FLOTT_GWD_rando(PHYS_TSTEP, pplay, t_seri, u_seri, v_seri, &
    42484437            rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, &
    42494438            du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress)
    42504439       CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, &
    42514440            paprs, 'flott_gwd_rando', abortphy,flag_inhib_tend,itap,0)
    4252        call prt_enerbil('flott_gwd_rando',itap)
     4441       CALL prt_enerbil('flott_gwd_rando',itap)
    42534442       zustr_gwd_rando=0.
    42544443       zvstr_gwd_rando=0.
    42554444       DO k = 1, klev
    4256           zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime &
     4445          zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/phys_tstep &
    42574446               * (paprs(:, k)-paprs(:, k+1))/rg
    4258           zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime &
     4447          zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/phys_tstep &
    42594448               * (paprs(:, k)-paprs(:, k+1))/rg
    42604449       ENDDO
    … …  
    42764465    DO k = 1, klev
    42774466       DO i = 1, klon
    4278           zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* &
     4467          zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/phys_tstep* &
    42794468               (paprs(i,k)-paprs(i,k+1))/rg
    4280           zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* &
     4469          zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/phys_tstep* &
    42814470               (paprs(i,k)-paprs(i,k+1))/rg
    42824471       ENDDO
    … …  
    42964485    !IM cf. FLott END
    42974486    !DC Calcul de la tendance due au methane
    4298     IF(ok_qch4) THEN
     4487    IF (ok_qch4) THEN
    42994488       CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay)
    43004489       ! ajout de la tendance d'humidite due au methane
    4301        d_q_ch4_dtime(:,:) = d_q_ch4(:,:)*dtime
     4490       d_q_ch4_dtime(:,:) = d_q_ch4(:,:)*phys_tstep
    43024491       CALL add_phys_tend(du0, dv0, dt0, d_q_ch4_dtime, dql0, dqi0, paprs, &
    43034492            'q_ch4', abortphy,flag_inhib_tend,itap,0)
    4304        d_q_ch4(:,:) = d_q_ch4_dtime(:,:)/dtime
     4493       d_q_ch4(:,:) = d_q_ch4_dtime(:,:)/phys_tstep
    43054494    ENDIF
    43064495    !
    … …  
    43134502! Inititialization
    43144503!------------------
    4315 
    4316    
    43174504
    43184505       addtkeoro=0   
    … …  
    43264513       alphatkeoro=min(max(0.,alphatkeoro),1.)
    43274514
    4328        smallscales_tkeoro=.false.   
     4515       smallscales_tkeoro=.FALSE.   
    43294516       CALL getin_p('smallscales_tkeoro',smallscales_tkeoro)
    43304517
    43314518
    4332         dtadd(:,:)=0.
    4333         duadd(:,:)=0.
    4334         dvadd(:,:)=0.
    4335 
    4336 
     4519       dtadd(:,:)=0.
     4520       duadd(:,:)=0.
     4521       dvadd(:,:)=0.
    43374522
    43384523! Choices for addtkeoro:
    … …  
    43494534
    43504535
    4351 
    43524536  IF (addtkeoro .EQ. 1 ) THEN
    43534537
    … …  
    43574541  ELSE IF (addtkeoro .EQ. 2) THEN
    43584542
    4359 
    4360 
    4361        IF (smallscales_tkeoro) THEN
     4543     IF (smallscales_tkeoro) THEN
    43624544       igwd=0
    43634545       DO i=1,klon
    … …  
    43824564             igwd=igwd+1
    43834565             idx(igwd)=i
    4384           ENDIF
    4385        ENDDO
    4386 
    4387        END IF
    4388 
    4389 
    4390 
    4391 
    4392        CALL drag_noro_strato(addtkeoro,klon,klev,dtime,paprs,pplay, &
     4566        ENDIF
     4567       ENDDO
     4568
     4569     ENDIF
     4570
     4571     CALL drag_noro_strato(addtkeoro,klon,klev,phys_tstep,paprs,pplay, &
    43934572               zmea,zstd, zsig, zgam, zthe,zpic,zval, &
    43944573               igwd,idx,itest, &
    … …  
    43974576               d_t_oro_gw, d_u_oro_gw, d_v_oro_gw)
    43984577
    4399             zustrdr(:)=0.
    4400             zvstrdr(:)=0.
    4401             zulow(:)=0.
    4402             zvlow(:)=0.
    4403 
    4404             duadd(:,:)=alphatkeoro*d_u_oro_gw(:,:)
    4405             dvadd(:,:)=alphatkeoro*d_v_oro_gw(:,:)
    4406  END IF
    4407    
     4578     zustrdr(:)=0.
     4579     zvstrdr(:)=0.
     4580     zulow(:)=0.
     4581     zvlow(:)=0.
     4582
     4583     duadd(:,:)=alphatkeoro*d_u_oro_gw(:,:)
     4584     dvadd(:,:)=alphatkeoro*d_v_oro_gw(:,:)
     4585  ENDIF
    44084586
    44094587
    … …  
    44164594
    44174595
    4418 
    44194596       ENDIF
    44204597!      -----
    44214598!===============================================================
    4422 
    44234599
    44244600
    … …  
    44314607       ! adeclarer
    44324608#ifdef CPP_COSP
    4433        IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN
     4609       IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/phys_tstep)).EQ.0) THEN
    44344610
    44354611          IF (prt_level .GE.10) THEN
    … …  
    44394615          !       print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=',
    44404616          !     s        ref_liq,ref_ice
    4441           CALL phys_cosp(itap,dtime,freq_cosp, &
     4617          CALL phys_cosp(itap,phys_tstep,freq_cosp, &
    44424618               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
    44434619               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
    … …  
    44624638
    44634639#ifdef CPP_COSP2
    4464        IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN
     4640       IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/phys_tstep)).EQ.0) THEN
    44654641
    44664642          IF (prt_level .GE.10) THEN
    … …  
    44704646                 print*,'Dans physiq.F avant appel '
    44714647          !     s        ref_liq,ref_ice
    4472           CALL phys_cosp2(itap,dtime,freq_cosp, &
     4648          CALL phys_cosp2(itap,phys_tstep,freq_cosp, &
    44734649               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
    44744650               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
    … …  
    44854661#endif
    44864662
     4663#ifdef CPP_COSPV2
     4664       IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/phys_tstep)).EQ.0) THEN
     4665
     4666          IF (prt_level .GE.10) THEN
     4667             print*,'freq_cosp',freq_cosp
     4668          ENDIF
     4669          mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse
     4670                 print*,'Dans physiq.F avant appel '
     4671          !     s        ref_liq,ref_ice
     4672          CALL lmdz_cosp_interface(itap,phys_tstep,freq_cosp, &
     4673               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
     4674               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
     4675               klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
     4676               JrNt,ref_liq,ref_ice, &
     4677               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
     4678               zu10m,zv10m,pphis, &
     4679               zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
     4680               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
     4681               prfl(:,1:klev),psfl(:,1:klev), &
     4682               pmflxr(:,1:klev),pmflxs(:,1:klev), &
     4683               mr_ozone,cldtau, cldemi)
     4684       ENDIF
     4685#endif
     4686
    44874687    ENDIF  !ok_cosp
    44884688
    … …  
    44924692  IF (ok_airs) then
    44934693
    4494   IF (itap.eq.1.or.MOD(itap,NINT(freq_airs/dtime)).EQ.0) THEN
     4694  IF (itap.eq.1.or.MOD(itap,NINT(freq_airs/phys_tstep)).EQ.0) THEN
    44954695     write(*,*) 'je vais appeler simu_airs, ok_airs, freq_airs=', ok_airs, freq_airs
    44964696     CALL simu_airs(itap,rneb, t_seri, cldemi, fiwc, ref_ice, pphi, pplay, paprs,&
    … …  
    45474747    CALL phytrac ( &
    45484748         itap,     days_elapsed+1,    jH_cur,   debut, &
    4549          lafin,    dtime,     u, v,     t, &
     4749         lafin,    phys_tstep,     u, v,     t, &
    45504750         paprs,    pplay,     pmfu,     pmfd, &
    45514751         pen_u,    pde_u,     pen_d,    pde_d, &
    … …  
    45824782            cdragh,coefh(1:klon,1:klev,is_ave),u1,v1,ftsol,pctsrf, &
    45834783            frac_impa, frac_nucl, &
    4584             pphis,cell_area,dtime,itap, &
     4784            pphis,cell_area,phys_tstep,itap, &
    45854785            qx(:,:,ivap),da,phi,mp,upwd,dnwd)
    45864786
    … …  
    46534853
    46544854       CALL chemhook_end ( &
    4655             dtime, &
     4855            phys_tstep, &
    46564856            pplay, &
    46574857            t_seri, &
    … …  
    46884888    DO k = 1, klev
    46894889       DO i = 1, klon
    4690           d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
    4691           d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
    4692           d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
    4693           d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
    4694           d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
     4890          d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / phys_tstep
     4891          d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / phys_tstep
     4892          d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / phys_tstep
     4893          d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / phys_tstep
     4894          d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / phys_tstep
    46954895          !CR: on ajoute le contenu en glace
    46964896          IF (nqo.eq.3) THEN
    4697              d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / dtime
     4897             d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / phys_tstep
    46984898          ENDIF
    46994899       ENDDO
    … …  
    47074907          DO  k = 1, klev
    47084908             DO  i = 1, klon
    4709                 ! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
    4710                 d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / dtime
     4909                ! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / phys_tstep
     4910                d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / phys_tstep
    47114911             ENDDO
    47124912          ENDDO
    … …  
    48775077    CALL phys_output_write(itap, pdtphys, paprs, pphis,  &
    48785078         pplay, lmax_th, aerosol_couple,                 &
    4879          ok_ade, ok_aie, ivap, iliq, isol, new_aod,      &
     5079         ok_ade, ok_aie, ok_volcan, ivap, iliq, isol, new_aod,      &
    48805080         ok_sync, ptconv, read_climoz, clevSTD,          &
    48815081         ptconvth, d_u, d_t, qx, d_qx, zmasse,           &
    … …  
    48905090
    48915091! On remet des variables a .false. apres un premier appel
    4892     if (debut) then
     5092    IF (debut) THEN
    48935093#ifdef CPP_XIOS
    48945094      swaero_diag=.FALSE.
    … …  
    48985098!      write (lunout,*)'ok_4xCO2atm= ',swaero_diag, swaerofree_diag, dryaod_diag, ok_4xCO2atm
    48995099
    4900       IF (is_master) then
     5100      IF (is_master) THEN
    49015101        !--setting up swaero_diag to TRUE in XIOS case
    49025102        IF (xios_field_is_active("topswad").OR.xios_field_is_active("topswad0").OR. &
    … …  
    49295129           xios_field_is_active("rld4co2").OR.xios_field_is_active("rldcs4co2")) &
    49305130           ok_4xCO2atm=.TRUE.
    4931       endif
     5131      ENDIF
    49325132      !$OMP BARRIER
    4933       call bcast(swaero_diag)
    4934       call bcast(swaerofree_diag)
    4935       call bcast(dryaod_diag)
    4936       call bcast(ok_4xCO2atm)
     5133      CALL bcast(swaero_diag)
     5134      CALL bcast(swaerofree_diag)
     5135      CALL bcast(dryaod_diag)
     5136      CALL bcast(ok_4xCO2atm)
    49375137!      write (lunout,*)'ok_4xCO2atm= ',swaero_diag, swaerofree_diag, dryaod_diag, ok_4xCO2atm
    49385138#endif
    4939     endif
     5139    ENDIF
    49405140
    49415141    !====================================================================
    … …  
    49625162       !         write(97) u_seri,v_seri,t_seri,q_seri
    49635163       !         close(97)
    4964        !$OMP MASTER
    4965        IF (read_climoz >= 1) THEN
    4966           IF (is_mpi_root) THEN
    4967              CALL nf95_close(ncid_climoz)
    4968           ENDIF
    4969           DEALLOCATE(press_edg_climoz) ! pointer
    4970           DEALLOCATE(press_cen_climoz) ! pointer
    4971        ENDIF
    4972        !$OMP END MASTER
    4973        print *,' physiq fin, nombre de steps ou cvpas = 1 : ', Ncvpaseq1
     5164     
     5165       IF (is_omp_master) THEN
     5166       
     5167         IF (read_climoz >= 1) THEN
     5168           IF (is_mpi_root) CALL nf95_close(ncid_climoz)
     5169            DEALLOCATE(press_edg_climoz) ! pointer
     5170            DEALLOCATE(press_cen_climoz) ! pointer
     5171         ENDIF
     5172       
     5173       ENDIF
     5174#ifdef CPP_XIOS
     5175       IF (is_omp_master) CALL xios_context_finalize
     5176#endif
     5177       WRITE(lunout,*) ' physiq fin, nombre de steps ou cvpas = 1 : ', Ncvpaseq1
    49745178    ENDIF
    49755179
    49765180    !      first=.false.
    49775181
    4978 
    49795182  END SUBROUTINE physiq
    49805183

  • LMDZ6/branches/Ocean_skin/libf/phylmd/phytrac_mod.F90

    • Property svn:keywords set to Id
    r3418 r3605  
    5454CONTAINS
    5555
     56  SUBROUTINE phytrac_init()
     57    USE dimphy
     58    USE infotrac_phy, ONLY: nbtr
     59    IMPLICIT NONE
     60
     61       ALLOCATE(d_tr_cl(klon,klev,nbtr),d_tr_dry(klon,nbtr))
     62       ALLOCATE(flux_tr_dry(klon,nbtr),d_tr_dec(klon,klev,nbtr),d_tr_cv(klon,klev,nbtr))
     63       ALLOCATE(d_tr_insc(klon,klev,nbtr),d_tr_bcscav(klon,klev,nbtr))
     64       ALLOCATE(d_tr_evapls(klon,klev,nbtr),d_tr_ls(klon,klev,nbtr))
     65       ALLOCATE(qPrls(klon,nbtr),d_tr_trsp(klon,klev,nbtr))
     66       ALLOCATE(d_tr_sscav(klon,klev,nbtr),d_tr_sat(klon,klev,nbtr))
     67       ALLOCATE(d_tr_uscav(klon,klev,nbtr),qPr(klon,klev,nbtr),qDi(klon,klev,nbtr))
     68       ALLOCATE(qPa(klon,klev,nbtr),qMel(klon,klev,nbtr))
     69       ALLOCATE(qTrdi(klon,klev,nbtr),dtrcvMA(klon,klev,nbtr))
     70       ALLOCATE(d_tr_th(klon,klev,nbtr))
     71       ALLOCATE(d_tr_lessi_impa(klon,klev,nbtr),d_tr_lessi_nucl(klon,klev,nbtr))
     72
     73  END SUBROUTINE phytrac_init
     74
    5675  SUBROUTINE phytrac(                                 &
    5776       nstep,     julien,   gmtime,   debutphy,       &
    … …  
    332351    !                    -- INITIALIZATION --
    333352    !######################################################################
    334     IF (debutphy) THEN
    335        ALLOCATE(d_tr_cl(klon,klev,nbtr),d_tr_dry(klon,nbtr))
    336        ALLOCATE(flux_tr_dry(klon,nbtr),d_tr_dec(klon,klev,nbtr),d_tr_cv(klon,klev,nbtr))
    337        ALLOCATE(d_tr_insc(klon,klev,nbtr),d_tr_bcscav(klon,klev,nbtr))
    338        ALLOCATE(d_tr_evapls(klon,klev,nbtr),d_tr_ls(klon,klev,nbtr))
    339        ALLOCATE(qPrls(klon,nbtr),d_tr_trsp(klon,klev,nbtr))
    340        ALLOCATE(d_tr_sscav(klon,klev,nbtr),d_tr_sat(klon,klev,nbtr))
    341        ALLOCATE(d_tr_uscav(klon,klev,nbtr),qPr(klon,klev,nbtr),qDi(klon,klev,nbtr))
    342        ALLOCATE(qPa(klon,klev,nbtr),qMel(klon,klev,nbtr))
    343        ALLOCATE(qTrdi(klon,klev,nbtr),dtrcvMA(klon,klev,nbtr))
    344        ALLOCATE(d_tr_th(klon,klev,nbtr))
    345        ALLOCATE(d_tr_lessi_impa(klon,klev,nbtr),d_tr_lessi_nucl(klon,klev,nbtr))
    346     ENDIF
    347353
    348354    DO k=1,klev
    … …  
    405411       !Config Key  = convscav
    406412       !Config Desc = Convective scavenging switch: 0=off, 1=on.
    407        !Config Def  = .false.
     413       !Config Def  = .FALSE.
    408414       !Config Help =
    409415       !
    410416!$OMP MASTER
    411        convscav_omp=.false.
     417       convscav_omp=.FALSE.
    412418       call getin('convscav', convscav_omp)
    413419       iflag_vdf_trac_omp=1
    … …  
    479485       CASE('co2i')
    480486          source(:,:)=0.
     487          lessivage  = .FALSE.
     488          aerosol(:) = .FALSE.
     489          pbl_flg(:) = 1
     490          iflag_the_trac= 1
     491          iflag_vdf_trac= 1
     492          iflag_con_trac= 1
    481493#ifdef CPP_StratAer
    482494       CASE('coag')
    … …  
    506518             CASE('lmdz')
    507519                IF (convscav.and.aerosol(it)) THEN
    508                    flag_cvltr(it)=.true.
     520                   flag_cvltr(it)=.TRUE.
    509521                   ccntrAA(it) =ccntrAA_in    !--a modifier par JYG a lire depuis fichier
    510522                   ccntrENV(it)=ccntrENV_in
    511523                   coefcoli(it)=coefcoli_in
    512524                ELSE
    513                    flag_cvltr(it)=.false.
     525                   flag_cvltr(it)=.FALSE.
    514526                ENDIF
    515527
    516528             CASE('repr')
    517                  flag_cvltr(it)=.false.
     529                 flag_cvltr(it)=.FALSE.
    518530
    519531             CASE('inca')
    520532!                IF ((it.EQ.id_Rn222) .OR. ((it.GE.id_SO2) .AND. (it.LE.id_NH3)) ) THEN
    521533!                   !--gas-phase species
    522 !                   flag_cvltr(it)=.false.
     534!                   flag_cvltr(it)=.FALSE.
    523535!
    524536!                ELSEIF ( (it.GE.id_CIDUSTM) .AND. (it.LE.id_AIN) ) THEN
    525537!                   !--insoluble aerosol species
    526 !                   flag_cvltr(it)=.true.
     538!                   flag_cvltr(it)=.TRUE.
    527539!                   ccntrAA(it)=0.7
    528540!                   ccntrENV(it)=0.7
    … …  
    530542!                ELSEIF ( (it.EQ.id_Pb210) .OR. ((it.GE.id_CSSSM) .AND. (it.LE.id_SSN))) THEN
    531543!                   !--soluble aerosol species
    532 !                   flag_cvltr(it)=.true.
     544!                   flag_cvltr(it)=.TRUE.
    533545!                   ccntrAA(it)=0.9
    534546!                   ccntrENV(it)=0.9
    … …  
    540552                !--test OB
    541553                !--for now we do not scavenge in cvltr
    542                 flag_cvltr(it)=.false.
     554                flag_cvltr(it)=.FALSE.
    543555
    544556             CASE('co2i')
    545557                !--co2 tracers are not scavenged
    546                 flag_cvltr(it)=.false.
     558                flag_cvltr(it)=.FALSE.
    547559
    548560#ifdef CPP_StratAer
    549561             CASE('coag')
    550562                IF (convscav.and.aerosol(it)) THEN
    551                    flag_cvltr(it)=.true.
     563                   flag_cvltr(it)=.TRUE.
    552564                   ccntrAA(it) =ccntrAA_in   
    553565                   ccntrENV(it)=ccntrENV_in
    554566                   coefcoli(it)=coefcoli_in
    555567                ELSE
    556                    flag_cvltr(it)=.false.
     568                   flag_cvltr(it)=.FALSE.
    557569                ENDIF
    558570#endif
    … …  
    562574          !
    563575       ELSE ! iflag_con .ne. 3
    564           flag_cvltr(:) = .false.
     576          flag_cvltr(:) = .FALSE.
    565577       ENDIF
    566578       !
    … …  
    590602       IF (lessivage .AND. type_trac .EQ. 'inca') THEN
    591603          CALL abort_physic('phytrac', 'lessivage=T config_inca=inca impossible',1)
    592           STOP
     604!          STOP
    593605       ENDIF
    594606       !
    595     END IF ! of IF (debutphy)
     607    ENDIF ! of IF (debutphy)
    596608    !############################################ END INITIALIZATION #######
    597609
    … …  
    637649       !   -- CO2 interactif --
    638650       !   -- source is updated with FF and BB emissions
    639        !   -- OB => PC need to add net flux from ocean and orchidee
     651       !   -- and net fluxes from ocean and orchidee
    640652       !   -- sign convention : positive into the atmosphere
     653
    641654       CALL tracco2i(pdtphys, debutphy, &
    642655            xlat, xlon, pphis, pphi, &
    … …  
    754767#endif
    755768
    756     END IF ! convection
     769    ENDIF ! convection
    757770
    758771    !======================================================================
    … …  
    792805       END DO ! it
    793806
    794     END IF ! Thermiques
     807    ENDIF ! Thermiques
    795808
    796809    !======================================================================
    … …  
    878891       CALL abort_physic('iflag_vdf_trac', 'cas non prevu',1)
    879892       !
    880     END IF ! couche limite
     893    ENDIF ! couche limite
    881894
    882895    !======================================================================
    … …  
    968981                      zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
    969982                      !
    970                    END DO
    971                 END DO
     983                   ENDDO
     984                ENDDO
    972985
    973986                DO k=klev-1, 1, -1
    … …  
    10141027                      !                                (1.-1./(frac_impa(i,k)*frac_nucl(i,k)))
    10151028                      !--------------
    1016                    END DO
    1017                 END DO
    1018              END IF
    1019           END DO
     1029                   ENDDO
     1030                ENDDO
     1031             ENDIF
     1032          ENDDO
    10201033          ! *********   end modified old version
    10211034
    … …  
    10531066                      ! ----------------------------------------------------------------------
    10541067                      tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
    1055                    END DO
    1056                 END DO
    1057              END IF
    1058           END DO
     1068                   ENDDO
     1069                ENDDO
     1070             ENDIF
     1071          ENDDO
    10591072
    10601073          ! *********   end old version
    10611074       ENDIF  !  iflag_lscav . EQ. 1, 2, 3 or 4
    10621075       !
    1063     END IF !  lessivage
     1076    ENDIF !  lessivage
    10641077
    10651078

  • LMDZ6/branches/Ocean_skin/libf/phylmd/radlwsw_m.F90

    r3412 r3605  
    1616   t,q,wo,&
    1717   cldfra, cldemi, cldtaupd,&
    18    ok_ade, ok_aie, flag_aerosol,&
     18   ok_ade, ok_aie, ok_volcan, flag_aerosol,&
    1919   flag_aerosol_strat, flag_aer_feedback, &
    2020   tau_aero, piz_aero, cg_aero,&
    … …  
    2525   ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
    2626   heat,heat0,cool,cool0,albpla,&
     27   heat_volc, cool_volc,&
    2728   topsw,toplw,solsw,sollw,&
    2829   sollwdown,&
    … …  
    100101  ! ok_ade---input-L- apply the Aerosol Direct Effect or not?
    101102  ! ok_aie---input-L- apply the Aerosol Indirect Effect or not?
     103  ! ok_volcan-input-L- activate volcanic diags (SW heat & LW cool rate, SW & LW flux)
    102104  ! flag_aerosol-input-I- aerosol flag from 0 to 6
    103105  ! flag_aerosol_strat-input-I- use stratospheric aerosols flag (0, 1, 2)
    … …  
    120122  ! solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind)
    121123  ! topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind)
     124  !
     125  ! heat_volc-----output-R- echauffement atmospherique  du au forcage volcanique (visible) (K/s)
     126  ! cool_volc-----output-R- refroidissement dans l'IR du au forcage volcanique (K/s)
    122127  !
    123128  ! ATTENTION: swai and swad have to be interpreted in the following manner:
    … …  
    193198
    194199  LOGICAL, INTENT(in)  :: ok_ade, ok_aie                                 ! switches whether to use aerosol direct (indirect) effects or not
     200  LOGICAL, INTENT(in)  :: ok_volcan                                      ! produce volcanic diags (SW/LW heat flux and rate)
    195201  LOGICAL              :: lldebug
    196202  INTEGER, INTENT(in)  :: flag_aerosol                                   ! takes value 0 (no aerosol) or 1 to 6 (aerosols)
    … …  
    228234  REAL,    INTENT(out) :: heat(KLON,KLEV), cool(KLON,KLEV)
    229235  REAL,    INTENT(out) :: heat0(KLON,KLEV), cool0(KLON,KLEV)
     236  REAL,    INTENT(out) :: heat_volc(KLON,KLEV), cool_volc(KLON,KLEV) !NL
    230237  REAL,    INTENT(out) :: topsw(KLON), toplw(KLON)
    231238  REAL,    INTENT(out) :: solsw(KLON), sollw(KLON), albpla(KLON)
    … …  
    294301  REAL(KIND=8) zheat(kdlon,kflev), zcool(kdlon,kflev)
    295302  REAL(KIND=8) zheat0(kdlon,kflev), zcool0(kdlon,kflev)
     303  REAL(KIND=8) zheat_volc(kdlon,kflev), zcool_volc(kdlon,kflev) !NL
    296304  REAL(KIND=8) ztopsw(kdlon), ztoplw(kdlon)
    297305  REAL(KIND=8) zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
    … …  
    308316  REAL(KIND=8) ztopswad0aero(kdlon), zsolswad0aero(kdlon)   ! Aerosol direct forcing at TOAand surface
    309317  REAL(KIND=8) ztopswaiaero(kdlon), zsolswaiaero(kdlon)     ! dito, indirect
     318!--NL
     319  REAL(KIND=8) zswadaero(kdlon,kflev+1)                       ! SW Aerosol direct forcing
     320  REAL(KIND=8) zlwadaero(kdlon,kflev+1)                       ! LW Aerosol direct forcing
    310321!-LW by CK
    311322  REAL(KIND=8) ztoplwadaero(kdlon), zsollwadaero(kdlon)     ! LW Aerosol direct forcing at TOAand surface
    … …  
    398409  cgaero(:,:,:,:)=0.
    399410  lldebug=.FALSE.
    400  
     411
     412  ztopsw_aero(:,:)  = 0. !ym missing init : warning : not initialized in SW_AEROAR4
     413  ztopsw0_aero(:,:) = 0. !ym missing init : warning : not initialized in SW_AEROAR4
     414  zsolsw_aero(:,:)  = 0. !ym missing init : warning : not initialized in SW_AEROAR4
     415  zsolsw0_aero(:,:) = 0. !ym missing init : warning : not initialized in SW_AEROAR4
     416
     417
     418   ZTOPSWADAERO(:)  = 0. !ym missing init
     419   ZSOLSWADAERO(:)  = 0. !ym missing init
     420   ZTOPSWAD0AERO(:) = 0. !ym missing init
     421   ZSOLSWAD0AERO(:) = 0. !ym missing init
     422   ZTOPSWAIAERO(:)  = 0. !ym missing init
     423   ZSOLSWAIAERO(:)  = 0. !ym missing init 
     424   ZTOPSWCF_AERO(:,:)= 0.!ym missing init 
     425   ZSOLSWCF_AERO(:,:) =0. !ym missing init 
     426
    401427  !
    402428  !-------------------------------------------
    … …  
    415441      heat(i,k)=0.
    416442      cool(i,k)=0.
     443      heat_volc(i,k)=0. !NL
     444      cool_volc(i,k)=0. !NL
    417445      heat0(i,k)=0.
    418446      cool0(i,k)=0.
    … …  
    558586      ENDDO
    559587      DO k = 1, kflev
    560       DO i = 1, kdlon
    561       zcool(i,k)=0.
    562       zcool0(i,k)=0.
    563       ENDDO
     588         DO i = 1, kdlon
     589            zcool(i,k)=0.
     590            zcool_volc(i,k)=0. !NL
     591            zcool0(i,k)=0.
     592         ENDDO
    564593      ENDDO
    565594      DO i = 1, kdlon
    … …  
    584613!----- Mise a zero des tableaux output du rayonnement SW-AR4
    585614      DO k = 1, kflev+1
    586       DO i = 1, kdlon
    587       ZFSUP(i,k)=0.
    588       ZFSDN(i,k)=0.
    589       ZFSUP0(i,k)=0.
    590       ZFSDN0(i,k)=0.
    591       ZFSUPC0(i,k)=0.
    592       ZFSDNC0(i,k)=0.
    593       ZFLUPC0(i,k)=0.
    594       ZFLDNC0(i,k)=0.
    595       ZSWFT0_i(i,k)=0.
    596       ZFCUP_i(i,k)=0.
    597       ZFCDWN_i(i,k)=0.
    598       ZFCCUP_i(i,k)=0.
    599       ZFCCDWN_i(i,k)=0.
    600       ZFLCCUP_i(i,k)=0.
    601       ZFLCCDWN_i(i,k)=0.
    602       ENDDO
     615         DO i = 1, kdlon
     616            ZFSUP(i,k)=0.
     617            ZFSDN(i,k)=0.
     618            ZFSUP0(i,k)=0.
     619            ZFSDN0(i,k)=0.
     620            ZFSUPC0(i,k)=0.
     621            ZFSDNC0(i,k)=0.
     622            ZFLUPC0(i,k)=0.
     623            ZFLDNC0(i,k)=0.
     624            ZSWFT0_i(i,k)=0.
     625            ZFCUP_i(i,k)=0.
     626            ZFCDWN_i(i,k)=0.
     627            ZFCCUP_i(i,k)=0.
     628            ZFCCDWN_i(i,k)=0.
     629            ZFLCCUP_i(i,k)=0.
     630            ZFLCCDWN_i(i,k)=0.
     631            zswadaero(i,k)=0. !--NL
     632         ENDDO
    603633      ENDDO
    604634      DO k = 1, kflev
    605       DO i = 1, kdlon
    606       zheat(i,k)=0.
    607       zheat0(i,k)=0.
    608       ENDDO
     635         DO i = 1, kdlon
     636            zheat(i,k)=0.
     637            zheat_volc(i,k)=0.
     638            zheat0(i,k)=0.
     639         ENDDO
    609640      ENDDO
    610641      DO i = 1, kdlon
    … …  
    708739!
    709740!--OB
    710 !--aerosol TOT  - anthropogenic+natural
    711 !--aerosol NAT  - natural only
     741!--aerosol TOT  - anthropogenic+natural - index 2
     742!--aerosol NAT  - natural only          - index 1
    712743!
    713744      DO i = 1, kdlon
    … …  
    729760!
    730761!--C. Kleinschmitt
    731 !--aerosol TOT  - anthropogenic+natural
    732 !--aerosol NAT  - natural only
     762!--aerosol TOT  - anthropogenic+natural - index 2
     763!--aerosol NAT  - natural only          - index 1
    733764!
    734765      DO i = 1, kdlon
    … …  
    854885         ZTOPSWAIAERO,ZSOLSWAIAERO, &
    855886         ZTOPSWCF_AERO,ZSOLSWCF_AERO, &
     887         ZSWADAERO, & !--NL
    856888         ZTOPLWADAERO,ZSOLLWADAERO,&  ! rajoute par C. Kleinscmitt pour LW diagnostics
    857889         ZTOPLWAD0AERO,ZSOLLWAD0AERO,&
    858890         ZTOPLWAIAERO,ZSOLLWAIAERO, &
    859          ok_ade, ok_aie, flag_aerosol,flag_aerosol_strat, flag_aer_feedback) ! flags aerosols
     891         ZLWADAERO, & !--NL
     892         ok_ade, ok_aie, ok_volcan, flag_aerosol,flag_aerosol_strat, flag_aer_feedback) ! flags aerosols
    860893           
    861894!        print *,'RADLWSW: apres RECMWF'
    … …  
    936969         ZFLDNC0(i,k+1)= ZFLCCDWN_i(i,k+1)
    937970         ZFLUPC0(i,k+1)= ZFLCCUP_i(i,k+1)
     971         IF(ok_volcan) THEN
     972            ZSWADAERO(i,k+1)=ZSWADAERO(i,k+1)*fract(i) !--NL
     973         ENDIF
     974         
    938975!   Nouveau calcul car visiblement ZSWFT et ZSWFC sont nuls dans RRTM cy32
    939976!   en sortie de radlsw.F90 - MPL 7.01.09
    … …  
    10161053           zcool(i,k)=(ZLWFT(i,k)-ZLWFT(i,k+1))*RDAY*RG/RCPD/PDP(i,k)
    10171054           zcool0(i,k)=(ZLWFT0_i(i,k)-ZLWFT0_i(i,k+1))*RDAY*RG/RCPD/PDP(i,k)
     1055           IF(ok_volcan) THEN
     1056              zheat_volc(i,k)=(ZSWADAERO(i,k+1)-ZSWADAERO(i,k))*RG/RCPD/PDP(i,k) !NL
     1057              zcool_volc(i,k)=(ZLWADAERO(i,k)-ZLWADAERO(i,k+1))*RG/RCPD/PDP(i,k) !NL
     1058           ENDIF
    10181059!          print *,'heat cool heat0 cool0 ',zheat(i,k),zcool(i,k),zheat0(i,k),zcool0(i,k)
    10191060!          ZFLUCUP_i(i,k)=ZFLUC_i(i,1,k)
    … …  
    11251166        heat0(iof+i,k) = zheat0(i,k)/zznormcp
    11261167        cool0(iof+i,k) = zcool0(i,k)/zznormcp
     1168        IF(ok_volcan) THEN !NL
     1169           heat_volc(iof+i,k) = zheat_volc(i,k)/zznormcp
     1170           cool_volc(iof+i,k) = zcool_volc(i,k)/zznormcp
     1171        ENDIF
    11271172      ENDDO
    11281173    ENDDO

  • LMDZ6/branches/Ocean_skin/libf/phylmd/readaerosolstrato.F90

    r2745 r3605  
    77    USE phys_cal_mod, ONLY : mth_cur
    88    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, &
    9                                  grid2dto1d_glo
     9                                 grid2dto1d_glo, grid_type, unstructured
    1010    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
    1111    USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
    … …  
    1515    USE aero_mod
    1616    USE dimphy
    17 
     17    USE print_control_mod, ONLY: prt_level,lunout
     18#ifdef CPP_XIOS
     19    USE xios
     20#endif
    1821    implicit none
    1922
    … …  
    4346    real, allocatable:: tauaerstrat_mois(:, :, :)
    4447    real, allocatable:: tauaerstrat_mois_glo(:, :)
     48    real, allocatable:: tau_aer_strat_mpi(:, :)
    4549
    4650! For NetCDF:
    … …  
    5862    data alpha_strat_wave/3.36780953,3.34667683,3.20444202,3.0293026,2.82108808/
    5963
     64    CHARACTER (len = 20)                      :: modname = 'readaerosolstrato'
     65    CHARACTER (len = 80)                      :: abort_message
     66
    6067!--------------------------------------------------------
    6168
    … …  
    6976
    7077    IF (nbands.NE.2) THEN
    71         print *,'nbands doit etre egal a 2 dans readaerosolstrat'
    72         STOP
     78        abort_message='nbands doit etre egal a 2 dans readaerosolstrat'
     79        CALL abort_physic(modname,abort_message,1)
    7380    ENDIF
    7481
    … …  
    7986    n_lev = size(lev)
    8087    IF (n_lev.NE.klev) THEN
    81        print *,'Le nombre de niveaux n est pas egal a klev'
    82        STOP
     88       abort_message='Le nombre de niveaux n est pas egal a klev'
     89       CALL abort_physic(modname,abort_message,1)
    8390    ENDIF
    8491
    … …  
    8693    CALL nf95_gw_var(ncid_in, varid, latitude)
    8794    n_lat = size(latitude)
    88     print *, 'LAT aerosol strato=', n_lat, latitude
    89     IF (n_lat.NE.nbp_lat) THEN
    90        print *,'Le nombre de lat n est pas egal a nbp_lat'
    91        STOP
    92     ENDIF
    93 
     95    WRITE(lunout,*) 'LAT aerosol strato=', n_lat, latitude
     96    IF (grid_type/=unstructured) THEN
     97      IF (n_lat.NE.nbp_lat) THEN
     98         abort_message='Le nombre de lat n est pas egal a nbp_lat'
     99         CALL abort_physic(modname,abort_message,1)
     100      ENDIF
     101    ENDIF
     102   
    94103    CALL nf95_inq_varid(ncid_in, "LON", varid)
    95104    CALL nf95_gw_var(ncid_in, varid, longitude)
    96105    n_lon = size(longitude)
    97     print *, 'LON aerosol strato=', n_lon, longitude
    98     IF (n_lon.NE.nbp_lon) THEN
    99        print *,'Le nombre de lon n est pas egal a nbp_lon'
    100        STOP
    101     ENDIF
    102 
     106    IF (grid_type/=unstructured) THEN
     107      WRITE(lunout,*) 'LON aerosol strato=', n_lon, longitude
     108      IF (n_lon.NE.nbp_lon) THEN
     109         abort_message='Le nombre de lon n est pas egal a nbp_lon'
     110         CALL abort_physic(modname,abort_message,1)
     111      ENDIF
     112    ENDIF
     113   
    103114    CALL nf95_inq_varid(ncid_in, "TIME", varid)
    104115    CALL nf95_gw_var(ncid_in, varid, time)
    105116    n_month = size(time)
    106     print *, 'TIME aerosol strato=', n_month, time
     117    WRITE(lunout,*) 'TIME aerosol strato=', n_month, time
    107118    IF (n_month.NE.12) THEN
    108        print *,'Le nombre de month n est pas egal a 12'
    109        STOP
     119       abort_message='Le nombre de month n est pas egal a 12'
     120       CALL abort_physic(modname,abort_message,1)
    110121    ENDIF
    111122
    … …  
    117128    CALL nf95_inq_varid(ncid_in, "TAUSTRAT", varid)
    118129    ncerr = nf90_get_var(ncid_in, varid, tauaerstrat)
    119     print *,'code erreur readaerosolstrato=', ncerr, varid
     130    WRITE(lunout,*) 'code erreur readaerosolstrato=', ncerr, varid
    120131
    121132    CALL nf95_close(ncid_in)
    … …  
    123134!---select the correct month
    124135    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
    125       print *,'probleme avec le mois dans readaerosolstrat =', mth_cur
     136     WRITE(lunout,*) 'probleme avec le mois dans readaerosolstrat =', mth_cur
    126137    ENDIF
    127138    tauaerstrat_mois(:,:,:) = tauaerstrat(:,:,:,mth_cur)
    … …  
    130141    CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo)
    131142
     143    ELSE
     144      ALLOCATE(tauaerstrat_mois(0,0,0))
    132145    ENDIF !--is_mpi_root and is_omp_root
    133146
    134147!$OMP BARRIER
    135148
     149    IF (grid_type==unstructured) THEN
     150#ifdef CPP_XIOS
     151      IF (is_omp_master) THEN
     152        CALL xios_send_field("taustrat_in",tauaerstrat_mois)
     153        ALLOCATE(tau_aer_strat_mpi(klon_mpi, klev))
     154        CALL xios_recv_field("taustrat_out",tau_aer_strat_mpi)
     155      ELSE
     156        ALLOCATE(tau_aer_strat_mpi(0,0))
     157      ENDIF
     158      CALL scatter_omp(tau_aer_strat_mpi,tau_aer_strat)
     159#endif
     160    ELSE 
    136161!--scatter on all proc
    137     CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
     162      CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
     163    ENDIF
    138164
    139165!--keep memory of previous month

  • LMDZ6/branches/Ocean_skin/libf/phylmd/readchlorophyll.F90

    r3298 r3605  
    1515    USE mod_phys_lmdz_para, ONLY: scatter
    1616    USE phys_state_var_mod, ONLY: chl_con
     17    USE print_control_mod, ONLY: prt_level,lunout
    1718
    1819    IMPLICIT NONE
    … …  
    4546
    4647!--------------------------------------------------------
     48    CHARACTER (len = 20)  :: modname = 'readchlorophyll'
     49    CHARACTER (len = 80)  :: abort_message
    4750
    4851!--only read file if beginning of run or start of new month
    … …  
    5659    CALL nf95_gw_var(ncid_in, varid, longitude)
    5760    n_lon = size(longitude)
    58 !    print *, 'LON chlorophyll=', n_lon, longitude
    5961    IF (n_lon.NE.nbp_lon) THEN
    60        print *,'Le nombre de lon n est pas egal a nbp_lon'
    61        STOP
     62       abort_message='Le nombre de lon n est pas egal a nbp_lon'
     63       CALL abort_physic(modname,abort_message,1)
    6264    ENDIF
    6365
    … …  
    6567    CALL nf95_gw_var(ncid_in, varid, latitude)
    6668    n_lat = size(latitude)
    67 !    print *, 'LAT chlorophyll=', n_lat, latitude
    6869    IF (n_lat.NE.nbp_lat) THEN
    69        print *,'Le nombre de lat n est pas egal a jnbp_lat'
    70        STOP
     70       abort_message='Le nombre de lat n est pas egal a jnbp_lat'
     71       CALL abort_physic(modname,abort_message,1)
    7172    ENDIF
    7273
    … …  
    7475    CALL nf95_gw_var(ncid_in, varid, time)
    7576    n_month = size(time)
    76 !    print *, 'TIME aerosol strato=', n_month, time
    7777    IF (n_month.NE.12) THEN
    78        print *,'Le nombre de month n est pas egal a 12'
    79        STOP
     78       abort_message='Le nombre de month n est pas egal a 12'
     79       CALL abort_physic(modname,abort_message,1)
    8080    ENDIF
    8181
    … …  
    8787    CALL nf95_inq_varid(ncid_in, "CHL", varid)
    8888    ncerr = nf90_get_var(ncid_in, varid, chlorocon)
    89     print *,'code erreur readchlorophyll=', ncerr, varid
     89    WRITE(lunout,*)'code erreur readchlorophyll=', ncerr, varid
    9090
    9191    CALL nf95_close(ncid_in)
    … …  
    9393!---select the correct month
    9494    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
    95       print *,'probleme avec le mois dans readchlorophyll =', mth_cur
     95      WRITE(lunout,*)'probleme avec le mois dans readchlorophyll =', mth_cur
    9696    ENDIF
    9797    chlorocon_mois(:,:) = chlorocon(:,:,mth_cur)
    … …  
    100100    CALL grid2dTo1d_glo(chlorocon_mois,chlorocon_mois_glo)
    101101
    102     print *,"chrolophyll current month",mth_cur
     102    WRITE(lunout,*)"chrolophyll current month",mth_cur
    103103    DO i=1,klon_glo
    104104!      if(isnan(chlorocon_mois_glo(i)))then ! isnan() is not in the Fortran standard...

  • LMDZ6/branches/Ocean_skin/libf/phylmd/regr_horiz_time_climoz_m.F90

    r3278 r3605  
    22
    33  USE interpolation,     ONLY: locate
    4   USE mod_grid_phy_lmdz, ONLY: nlon_ou => nbp_lon, nlat_ou => nbp_lat
     4  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured
    55  USE nrtype,            ONLY: pi
    66  USE netcdf,   ONLY: NF90_CLOBBER, NF90_FLOAT,     NF90_GET_VAR, NF90_OPEN,   &
    … …  
    1111          NF95_CLOSE, NF95_ENDDEF,  NF95_PUT_ATT,   NF95_PUT_VAR, NF95_COPY_ATT
    1212  USE print_control_mod, ONLY: lunout
     13  USE dimphy
    1314  IMPLICIT NONE
    1415  PRIVATE
    … …  
    1617  REAL, PARAMETER :: deg2rad=pi/180.
    1718  CHARACTER(LEN=13), PARAMETER :: vars_in(2)=['tro3         ','tro3_daylight']
     19
     20  INTEGER :: nlat_ou, nlon_ou
     21  REAL, ALLOCATABLE :: latitude_glo(:)
     22!$OMP THREADPRIVATE(latitude_glo)
     23  INTEGER, ALLOCATABLE :: ind_cell_glo_glo(:)
     24!$OMP THREADPRIVATE(ind_cell_glo_glo)
    1825
    1926CONTAINS
    … …  
    5259  USE assert_m,           ONLY: assert
    5360  USE cal_tools_m,        ONLY: year_len, mid_month
    54   USE control_mod,        ONLY: anneeref
     61!!  USE control_mod,        ONLY: anneeref
     62  USE time_phylmdz_mod,   ONLY: annee_ref
    5563  USE ioipsl,             ONLY: ioget_year_len, ioget_calendar
    5664  USE regr_conserv_m,     ONLY: regr_conserv
    … …  
    5866  USE regular_lonlat_mod, ONLY: boundslon_reg, boundslat_reg, south, west, east
    5967  USE slopes_m,           ONLY: slopes
     68#ifdef CPP_XIOS
     69  USE xios
     70#endif
     71  USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_master, is_omp_master, gather, gather_mpi, bcast_mpi, klon_mpi
     72  USE geometry_mod, ONLY : latitude_deg, ind_cell_glo
     73  USE mod_grid_phy_lmdz, ONLY: klon_glo
     74
    6075!-------------------------------------------------------------------------------
    6176! Arguments:
    … …  
    8398  CHARACTER(LEN=20) :: cal_in              ! Calendar
    8499  REAL, ALLOCATABLE :: o3_in3(:,:,:,:,:)   ! Ozone climatologies
     100  REAL, ALLOCATABLE :: o3_in3bis(:,:,:,:,:)   ! Ozone climatologies
    85101  REAL, ALLOCATABLE :: o3_in2  (:,:,:,:)   ! Ozone climatologies
     102  REAL, ALLOCATABLE :: o3_in2bis(:,:,:,:,:)   ! Ozone climatologies
    86103  ! last index: 1 for the day-night average, 2 for the daylight field.
    87104  REAL :: NaN
    … …  
    91108  REAL, ALLOCATABLE :: o3_regr_lonlat(:,:,:,:,:) ! (nlon_ou,nlat_ou,:,0:13   ,:)
    92109  REAL, ALLOCATABLE :: o3_out3       (:,:,:,:,:) ! (nlon_ou,nlat_ou,:,ntim_ou,:)
     110  REAL, ALLOCATABLE :: o3_out3_glo   (:,:,:,:) !   (nbp_lat,:,ntim_ou,:)
    93111  REAL, ALLOCATABLE :: o3_regr_lat     (:,:,:,:) !         (nlat_in,:,0:13   ,:)
    94112  REAL, ALLOCATABLE :: o3_out2         (:,:,:,:) !         (nlat_ou,:,ntim_ou,:)
     113  REAL, ALLOCATABLE :: o3_out2_glo     (:,:,:,:) !         (nbp_lat,:,ntim_ou,:)
     114  REAL, ALLOCATABLE :: o3_out          (:,:,:,:) !         (nbp_lat,:,ntim_ou,:)
    95115! Dimension number  | Interval                | Contains  | For variables:
    96116!   1 (longitude)   | [rlonu(i-1), rlonu(i)]  | rlonv(i)  | all
    … …  
    116136  INTEGER, ALLOCATABLE :: sta(:), cnt(:)
    117137  CHARACTER(LEN=80) :: sub, dim_nam, msg
    118 !-------------------------------------------------------------------------------
    119   sub="regr_horiz_time_climoz"
    120   WRITE(lunout,*)"Call sequence information: "//TRIM(sub)
    121   CALL assert(read_climoz == 1 .OR. read_climoz == 2, "regr_lat_time_climoz")
    122 
    123   CALL  NF95_OPEN("climoz.nc"  , NF90_NOWRITE, fID_in)
    124   lprev=NF90_OPEN("climoz_m.nc", NF90_NOWRITE, fID_in_m)==NF90_NOERR
    125   lnext=NF90_OPEN("climoz_p.nc", NF90_NOWRITE, fID_in_p)==NF90_NOERR
    126 
    127   !--- Get coordinates from the input file. Converts lon/lat in radians.
    128   !    Few inversions because "regr_conserv" and gcm need ascending vectors.
    129   CALL NF95_INQ_VARID(fID_in, vars_in(1), varid)
    130   CALL NF95_INQUIRE_VARIABLE(fID_in, varid, dimids=dIDs, ndims=ndims)
    131   l3D=ndims==4; l2D=ndims==3
    132   IF(l3D) WRITE(lunout,*)"Input files contain full 3D ozone fields."
    133   IF(l2D) WRITE(lunout,*)"Input files contain zonal 2D ozone fields."
    134   DO i=1,ndims
    135     CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), name=dim_nam, nclen=dln)
    136     CALL NF95_INQ_VARID(fID_in, dim_nam, varid)
    137     ii=i; IF(l2D) ii=i+1                              !--- ndims==3:NO LONGITUDE
    138     SELECT CASE(ii)
    139       CASE(1)                                         !--- LONGITUDE
    140         CALL NF95_GW_VAR(fID_in, varid, lon_in)
    141         ldec_lon=lon_in(1)>lon_in(dln); IF(ldec_lon) lon_in=lon_in(dln:1:-1)
    142         nlon_in=dln; lon_in=lon_in*deg2rad
    143       CASE(2)                                         !--- LATITUDE
    144         CALL NF95_GW_VAR(fID_in, varid, lat_in)
    145         ldec_lat=lat_in(1)>lat_in(dln); IF(ldec_lat) lat_in=lat_in(dln:1:-1)
    146         nlat_in=dln; lat_in=lat_in*deg2rad
    147       CASE(3)                                         !--- PRESSURE LEVELS
    148         CALL NF95_GW_VAR(fID_in, varid, lev_in)
    149         ldec_lev=lev_in(1)>lev_in(dln); IF(ldec_lev) lev_in=lev_in(dln:1:-1)
    150         nlev_in=dln
    151         CALL NF95_GET_ATT(fID_in, varid, "units", press_unit)
    152         k=LEN_TRIM(press_unit)
    153         DO WHILE(ICHAR(press_unit(k:k))==0)
    154           press_unit(k:k)=' '; k=LEN_TRIM(press_unit) !--- REMOVE NULL END CHAR
    155         END DO
    156         IF(press_unit ==  "Pa") THEN
    157           lev_in = lev_in/100.                        !--- CONVERT TO hPa
    158         ELSE IF(press_unit /= "hPa") THEN
    159           CALL abort_physic(sub, "the only recognized units are Pa and hPa.",1)
     138  REAL :: null_array(0)
     139  LOGICAL,SAVE :: first=.TRUE.
     140!$OMP THREADPRIVATE(first) 
     141  REAL, ALLOCATABLE :: test_o3_in(:,:)
     142  REAL, ALLOCATABLE :: test_o3_out(:)
     143
     144
     145  IF (grid_type==unstructured) THEN
     146    IF (first) THEN
     147      IF (is_master) THEN
     148        ALLOCATE(latitude_glo(klon_glo))
     149        ALLOCATE(ind_cell_glo_glo(klon_glo))
     150      ELSE
     151        ALLOCATE(latitude_glo(0))
     152        ALLOCATE(ind_cell_glo_glo(0))
     153      ENDIF
     154      CALL gather(latitude_deg,  latitude_glo)
     155      CALL gather(ind_cell_glo,  ind_cell_glo_glo)
     156    ENDIF
     157  ENDIF
     158   
     159  IF (is_omp_master) THEN
     160    nlat_ou=nbp_lat
     161    nlon_ou=nbp_lon
     162   
     163   !-------------------------------------------------------------------------------
     164    IF (is_mpi_root) THEN
     165      sub="regr_horiz_time_climoz"
     166      WRITE(lunout,*)"Call sequence information: "//TRIM(sub)
     167      CALL assert(read_climoz == 1 .OR. read_climoz == 2, "regr_lat_time_climoz")
     168
     169      CALL  NF95_OPEN("climoz.nc"  , NF90_NOWRITE, fID_in)
     170      lprev=NF90_OPEN("climoz_m.nc", NF90_NOWRITE, fID_in_m)==NF90_NOERR
     171      lnext=NF90_OPEN("climoz_p.nc", NF90_NOWRITE, fID_in_p)==NF90_NOERR
     172
     173      !--- Get coordinates from the input file. Converts lon/lat in radians.
     174      !    Few inversions because "regr_conserv" and gcm need ascending vectors.
     175      CALL NF95_INQ_VARID(fID_in, vars_in(1), varid)
     176      CALL NF95_INQUIRE_VARIABLE(fID_in, varid, dimids=dIDs, ndims=ndims)
     177      l3D=ndims==4; l2D=ndims==3
     178      IF(l3D) WRITE(lunout,*)"Input files contain full 3D ozone fields."
     179      IF(l2D) WRITE(lunout,*)"Input files contain zonal 2D ozone fields."
     180      DO i=1,ndims
     181        CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), name=dim_nam, nclen=dln)
     182        CALL NF95_INQ_VARID(fID_in, dim_nam, varid)
     183        ii=i; IF(l2D) ii=i+1                              !--- ndims==3:NO LONGITUDE
     184        SELECT CASE(ii)
     185          CASE(1)                                         !--- LONGITUDE
     186            CALL NF95_GW_VAR(fID_in, varid, lon_in)
     187            ldec_lon=lon_in(1)>lon_in(dln); IF(ldec_lon) lon_in=lon_in(dln:1:-1)
     188            nlon_in=dln; lon_in=lon_in*deg2rad
     189          CASE(2)                                         !--- LATITUDE
     190            CALL NF95_GW_VAR(fID_in, varid, lat_in)
     191            ldec_lat=lat_in(1)>lat_in(dln); IF(ldec_lat) lat_in=lat_in(dln:1:-1)
     192            nlat_in=dln; lat_in=lat_in*deg2rad
     193          CASE(3)                                         !--- PRESSURE LEVELS
     194            CALL NF95_GW_VAR(fID_in, varid, lev_in)
     195            ldec_lev=lev_in(1)>lev_in(dln); IF(ldec_lev) lev_in=lev_in(dln:1:-1)
     196            nlev_in=dln
     197            CALL NF95_GET_ATT(fID_in, varid, "units", press_unit)
     198            k=LEN_TRIM(press_unit)
     199            DO WHILE(ICHAR(press_unit(k:k))==0)
     200              press_unit(k:k)=' '; k=LEN_TRIM(press_unit) !--- REMOVE NULL END CHAR
     201            END DO
     202            IF(press_unit ==  "Pa") THEN
     203              lev_in = lev_in/100.                        !--- CONVERT TO hPa
     204            ELSE IF(press_unit /= "hPa") THEN
     205              CALL abort_physic(sub, "the only recognized units are Pa and hPa.",1)
     206            END IF
     207          CASE(4)                                         !--- TIME
     208            CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), nclen=nmth_in)
     209            cal_in='gregorian'
     210            IF(NF90_GET_ATT(fID_in, varid, 'calendar', cal_in)/=NF90_NOERR)        & 
     211            WRITE(lunout,*)'WARNING: missing "calendar" attribute for "'//       &
     212            TRIM(dim_nam)//'" in "climoz.nc". Choosing default: "gregorian".'
     213            k=LEN_TRIM(cal_in)
     214            DO WHILE(ICHAR(cal_in(k:k))==0)
     215              cal_in(k:k)=' '; k=LEN_TRIM(cal_in)         !--- REMOVE NULL END CHAR
     216            END DO
     217        END SELECT
     218      END DO
     219
     220      !--- Prepare quantities for time interpolation
     221      tmidmonth=mid_month(annee_ref, cal_in)
     222      IF(interpt) THEN
     223        ntim_ou=ioget_year_len(annee_ref)
     224        ALLOCATE(tmidday(ntim_ou))
     225        tmidday=[(REAL(k)-0.5,k=1,ntim_ou)]
     226        CALL ioget_calendar(cal_ou)
     227      ELSE
     228        ntim_ou=14
     229        cal_ou=cal_in
     230      END IF
     231    ENDIF
     232
     233    IF (grid_type==unstructured) THEN
     234      CALL bcast_mpi(nlon_in)
     235      CALL bcast_mpi(nlat_in)
     236      CALL bcast_mpi(nlev_in)
     237      CALL bcast_mpi(l3d)
     238      CALL bcast_mpi(tmidmonth)
     239      CALL bcast_mpi(tmidday)
     240      CALL bcast_mpi(ntim_ou)
     241
     242#ifdef CPP_XIOS   
     243      IF (is_mpi_root) THEN
     244        CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=nlat_in, jbegin=0, latvalue_1d=lat_in/deg2rad)
     245        IF (l3D) THEN
     246          CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=nlon_in, ibegin=0, lonvalue_1d=lon_in/deg2rad)
     247        ELSE
     248          CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
     249        ENDIF
     250      ELSE
     251        CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=0, jbegin=0, latvalue_1d=null_array )
     252        IF (l3D) THEN
     253          CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=0, ibegin=0, lonvalue_1d=null_array)
     254        ELSE
     255          CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
     256        ENDIF
     257      ENDIF
     258      CALL  xios_set_axis_attr("axis_climoz", n_glo=nlev_in)
     259      CALL  xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou)
     260      CALL  xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou)
     261      CALL  xios_set_axis_attr("tr_climoz", n_glo=read_climoz)
     262      CALL  xios_set_field_attr("tro3_out", enabled=.TRUE.)
     263      CALL  xios_set_field_attr("tro3_out", enabled=.TRUE.)
     264#endif
     265     
     266      IF (first) THEN
     267        first=.FALSE.
     268        RETURN
     269      ENDIF
     270    ENDIF
     271   
     272   
     273    IF (is_mpi_root) THEN     
     274      !--- Longitudes management:
     275      !    * Need to shift data if the origin of input file longitudes /= -pi
     276      !    * Need to add some margin in longitude to ensure input interval contains
     277      !      all the output intervals => at least one longitudes slice has to be
     278      !      duplicated, possibly more for undersampling.
     279      IF(l3D) THEN
     280        IF (grid_type==unstructured) THEN
     281          dx2=0
     282        ELSE
     283          !--- Compute input edges longitudes vector (no end point yet)
     284          ALLOCATE(v1(nlon_in+1))
     285          v1(1)=(lon_in(nlon_in)+lon_in(1))/2.-pi
     286          FORALL(i=2:nlon_in) v1(i)=(lon_in(i-1)+lon_in(i))/2.
     287          v1(nlon_in+1)=v1(1)+2.*pi
     288          DEALLOCATE(lon_in)
     289
     290          !--- Shift input longitudes vector until it contains first output point boundslon_reg(1,west)
     291          v1=v1+2*pi*REAL(FLOOR((boundslon_reg(1,west)-v1(1))/(2.*pi)))
     292
     293          !--- Ensure first input longitudes interval contains first output point boundslon_reg(1,west)
     294          dx1=locate(v1,boundslon_reg(1,west))-1
     295          v1=CSHIFT(v1,SHIFT=dx1,DIM=1)
     296          v1(nlon_in-dx1+2:)=v1(nlon_in-dx1+2:)+2.*pi
     297   
     298          !--- Extend input longitudes vector until last interval contains boundslon_reg(nlat_ou,east)
     299          dx2=0; DO WHILE(v1(1+dx2)+2.*pi<=boundslon_reg(nlon_ou,east)); dx2=dx2+1; END DO
     300
     301          !--- Final edges longitudes vector (with margin and end point)
     302          ALLOCATE(lon_in_edge(nlon_in+dx2+1)); lon_in_edge=[v1,v1(2:1+dx2)+2.*pi]
     303          DEALLOCATE(v1)
     304        ENDIF
     305      END IF
     306
     307      !--- Compute sinus of intervals edges latitudes:
     308      ALLOCATE(sinlat_in_edge(nlat_in+1))
     309      sinlat_in_edge(1) = -1. ; sinlat_in_edge(nlat_in+1) = 1.
     310      FORALL(j=2:nlat_in) sinlat_in_edge(j)=SIN((lat_in(j-1)+lat_in(j))/2.)
     311      DEALLOCATE(lat_in)
     312
     313
     314
     315      !--- Check for contiguous years:
     316      ib=0; ie=13
     317      IF(nmth_in == 14) THEN; lprev=.FALSE.; lnext=.FALSE.
     318        WRITE(lunout,*)'Using 14 months ozone climatology "climoz.nc"...'
     319      ELSE 
     320        IF(     lprev) WRITE(lunout,*)'Using "climoz_m.nc" last record (previous year).'
     321        IF(.NOT.lprev) WRITE(lunout,*)"No previous year file ; assuming periodicity."
     322        IF(     lnext) WRITE(lunout,*)'Using "climoz_p.nc" first record (next year).'
     323        IF(.NOT.lnext) WRITE(lunout,*)"No next year file ; assuming periodicity."
     324        IF(.NOT.lprev) ib=1
     325        IF(.NOT.lnext) ie=12
     326      END IF
     327      ALLOCATE(sta(ndims),cnt(ndims)); sta(:)=1 
     328      IF(l3D) cnt=[nlon_in,nlat_in,nlev_in,1]
     329      IF(l2D) cnt=[        nlat_in,nlev_in,1] 
     330      IF(l3D) ALLOCATE(o3_in3(nlon_in+dx2,nlat_in,nlev_in,ib:ie,read_climoz))
     331      IF(l2D) ALLOCATE(o3_in2(            nlat_in,nlev_in,ib:ie,read_climoz))
     332
     333      !--- Read full current file and one record each available contiguous file
     334      DO iv=1,read_climoz
     335        msg=TRIM(sub)//" NF90_GET_VAR "//TRIM(vars_in(iv))
     336        CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv))
     337        IF(l3D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv))
     338        IF(l2D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in2(          :,:,1:12,iv))
     339        CALL handle_err(TRIM(msg), ncerr, fID_in)
     340        IF(lprev) THEN; sta(ndims)=12 
     341          CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv))
     342          IF(l3D) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt)
     343          IF(l2d) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in2(          :,:, 0,iv),sta,cnt)
     344          CALL handle_err(TRIM(msg)//" previous", ncerr, fID_in_m)
    160345        END IF
    161       CASE(4)                                         !--- TIME
    162         CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), nclen=nmth_in)
    163         cal_in='gregorian'
    164         IF(NF90_GET_ATT(fID_in, varid, 'calendar', cal_in)/=NF90_NOERR)        &
    165           WRITE(lunout,*)'WARNING: missing "calendar" attribute for "'//       &
    166           TRIM(dim_nam)//'" in "climoz.nc". Choosing default: "gregorian".'
    167         k=LEN_TRIM(cal_in)
    168         DO WHILE(ICHAR(cal_in(k:k))==0)
    169           cal_in(k:k)=' '; k=LEN_TRIM(cal_in)         !--- REMOVE NULL END CHAR
    170         END DO
    171     END SELECT
    172   END DO
    173 
    174   !--- Longitudes management:
    175   !    * Need to shift data if the origin of input file longitudes /= -pi
    176   !    * Need to add some margin in longitude to ensure input interval contains
    177   !      all the output intervals => at least one longitudes slice has to be
    178   !      duplicated, possibly more for undersampling.
    179   IF(l3D) THEN
    180     !--- Compute input edges longitudes vector (no end point yet)
    181     ALLOCATE(v1(nlon_in+1))
    182     v1(1)=(lon_in(nlon_in)+lon_in(1))/2.-pi
    183     FORALL(i=2:nlon_in) v1(i)=(lon_in(i-1)+lon_in(i))/2.
    184     v1(nlon_in+1)=v1(1)+2.*pi
    185     DEALLOCATE(lon_in)
    186 
    187     !--- Shift input longitudes vector until it contains first output point boundslon_reg(1,west)
    188     v1=v1+2*pi*REAL(FLOOR((boundslon_reg(1,west)-v1(1))/(2.*pi)))
    189 
    190     !--- Ensure first input longitudes interval contains first output point boundslon_reg(1,west)
    191     dx1=locate(v1,boundslon_reg(1,west))-1
    192     v1=CSHIFT(v1,SHIFT=dx1,DIM=1); v1(nlon_in-dx1+2:)=v1(nlon_in-dx1+2:)+2.*pi
    193 
    194     !--- Extend input longitudes vector until last interval contains boundslon_reg(nlon_ou,east)
    195     dx2=0; DO WHILE(v1(1+dx2)+2.*pi<=boundslon_reg(nlon_ou,east)); dx2=dx2+1; END DO
    196 
    197     !--- Final edges longitudes vector (with margin and end point)
    198     ALLOCATE(lon_in_edge(nlon_in+dx2+1)); lon_in_edge=[v1,v1(2:1+dx2)+2.*pi]
    199     DEALLOCATE(v1)
    200   END IF
    201 
    202   !--- Compute sinus of intervals edges latitudes:
    203   ALLOCATE(sinlat_in_edge(nlat_in+1))
    204   sinlat_in_edge(1) = -1. ; sinlat_in_edge(nlat_in+1) = 1.
    205   FORALL(j=2:nlat_in) sinlat_in_edge(j)=SIN((lat_in(j-1)+lat_in(j))/2.)
    206   DEALLOCATE(lat_in)
    207 
    208   !--- Prepare quantities for time interpolation
    209   tmidmonth=mid_month(anneeref, cal_in)
    210   IF(interpt) THEN
    211     ntim_ou=ioget_year_len(anneeref)
    212     ALLOCATE(tmidday(ntim_ou))
    213     tmidday=[(REAL(k)-0.5,k=1,ntim_ou)]
    214     CALL ioget_calendar(cal_ou)
    215   ELSE
    216     ntim_ou=14
    217     cal_ou=cal_in
    218   END IF
    219 
    220   !--- Create the output file and get the variable IDs:
    221   CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
    222                    ndims, cal_ou)
    223 
    224   !--- Write remaining coordinate variables:
    225   CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
    226   IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
    227   IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
    228 
    229   !--- Check for contiguous years:
    230   ib=0; ie=13
    231   IF(nmth_in == 14) THEN; lprev=.FALSE.; lnext=.FALSE.
    232     WRITE(lunout,*)'Using 14 months ozone climatology "climoz.nc"...'
    233   ELSE
    234     IF(     lprev) WRITE(lunout,*)'Using "climoz_m.nc" last record (previous year).'
    235     IF(.NOT.lprev) WRITE(lunout,*)"No previous year file ; assuming periodicity."
    236     IF(     lnext) WRITE(lunout,*)'Using "climoz_p.nc" first record (next year).'
    237     IF(.NOT.lnext) WRITE(lunout,*)"No next year file ; assuming periodicity."
    238     IF(.NOT.lprev) ib=1
    239     IF(.NOT.lnext) ie=12
    240   END IF
    241   ALLOCATE(sta(ndims),cnt(ndims)); sta(:)=1
    242   IF(l3D) cnt=[nlon_in,nlat_in,nlev_in,1]
    243   IF(l2D) cnt=[        nlat_in,nlev_in,1]
    244   IF(l3D) ALLOCATE(o3_in3(nlon_in+dx2,nlat_in,nlev_in,ib:ie,read_climoz))
    245   IF(l2D) ALLOCATE(o3_in2(            nlat_in,nlev_in,ib:ie,read_climoz))
    246 
    247   !--- Read full current file and one record each available contiguous file
    248   DO iv=1,read_climoz
    249     msg=TRIM(sub)//" NF90_GET_VAR "//TRIM(vars_in(iv))
    250     CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv))
    251     IF(l3D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv))
    252     IF(l2D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in2(          :,:,1:12,iv))
    253     CALL handle_err(TRIM(msg), ncerr, fID_in)
    254     IF(lprev) THEN; sta(ndims)=12
    255       CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv))
    256       IF(l3D) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt)
    257       IF(l2d) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in2(          :,:, 0,iv),sta,cnt)
    258       CALL handle_err(TRIM(msg)//" previous", ncerr, fID_in_m)
     346        IF(lnext) THEN; sta(ndims)=1 
     347          CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv))
     348          IF(l3D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt)
     349          IF(l2D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in2(          :,:,13,iv),sta,cnt)
     350          CALL handle_err(TRIM(msg)//" next", ncerr, fID_in_p)
     351        END IF
     352      END DO
     353      IF(lprev.OR.lnext) DEALLOCATE(sta,cnt)
     354      IF(lprev) CALL NF95_CLOSE(fID_in_m)
     355      IF(lnext) CALL NF95_CLOSE(fID_in_p)
     356
     357      !--- Revert decreasing coordinates vector
     358      IF(l3D) THEN
     359        IF(ldec_lon) o3_in3(1:nlon_in,:,:,:,:) = o3_in3(nlon_in:1:-1,:,:,:,:)
     360        IF(ldec_lat) o3_in3 = o3_in3(:,nlat_in:1:-1,:,:,:)
     361        IF(ldec_lev) o3_in3 = o3_in3(:,:,nlev_in:1:-1,:,:)
     362       
     363        IF (grid_type /= unstructured) THEN
     364          !--- Shift values for longitude and duplicate some longitudes slices
     365          o3_in3(1:nlon_in,:,:,:,:)=CSHIFT(o3_in3(1:nlon_in,:,:,:,:),SHIFT=dx1,DIM=1)
     366          o3_in3(nlon_in+1:nlon_in+dx2,:,:,:,:)=o3_in3(1:dx2,:,:,:,:)
     367        ENDIF
     368      ELSE
     369        IF(ldec_lat) o3_in2 = o3_in2(  nlat_in:1:-1,:,:,:)
     370        IF(ldec_lev) o3_in2 = o3_in2(  :,nlev_in:1:-1,:,:)
     371      END IF
     372
     373     !--- Deal with missing values
     374      DO m=1, read_climoz
     375        WRITE(msg,'(a,i0)')"regr_lat_time_climoz: field Nr.",m
     376        IF(NF90_GET_ATT(fID_in,vID_in(m),"missing_value",NaN)/= NF90_NOERR) THEN
     377          IF(NF90_GET_ATT(fID_in, vID_in(m),"_FillValue",NaN)/= NF90_NOERR) THEN
     378            WRITE(lunout,*)TRIM(msg)//": no missing value attribute found."; CYCLE
     379          END IF
     380        END IF
     381        WRITE(lunout,*)TRIM(msg)//": missing value attribute found."
     382        WRITE(lunout,*)"Trying to fill in NaNs ; a full field would be better."
     383
     384        !--- Check top layer contains no NaNs & search NaNs from top to ground
     385        msg=TRIM(sub)//": NaNs in top layer !"
     386        IF(l3D) THEN
     387          IF(ANY(o3_in3(:,:,1,:,m)==NaN)) CALL abort_physic(sub,msg,1)
     388          DO k = 2,nlev_in
     389            WHERE(o3_in3(:,:,k,:,m)==NaN) o3_in3(:,:,k,:,m)=o3_in3(:,:,k-1,:,m)
     390          END DO
     391        ELSE
     392          IF(ANY(o3_in2(  :,1,:,m)==NaN)) THEN
     393            WRITE(lunout,*)msg
     394            !--- Fill in latitudes where all values are missing
     395            DO l=1,nmth_in
     396              !--- Next to south pole
     397              j=1;       DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
     398              IF(j>1) &
     399                o3_in2(:j-1,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=j-1)
     400              !--- Next to north pole
     401              j=nlat_in; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
     402              IF(j<nlat_in) &
     403                o3_in2(j+1:,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=nlat_in-j)
     404            END DO
     405          END IF
     406
     407          !--- Fill in high latitudes missing values
     408          !--- Highest level been filled-in, so has always valid values.
     409          DO k = 2,nlev_in
     410            WHERE(o3_in2(:,k,:,m)==NaN) o3_in2(:,k,:,m)=o3_in2(:,k-1,:,m)
     411          END DO
     412        END IF
     413      END DO
     414
     415    ENDIF
     416   
     417    !=============================================================================
     418    IF(l3D) THEN                                                   !=== 3D FIELDS
     419    !=============================================================================
     420     IF (grid_type==unstructured) THEN
     421#ifdef CPP_XIOS
     422       nlat_ou=klon_mpi
     423       
     424       IF (is_mpi_root) THEN
     425         ALLOCATE(o3_in3bis(nlon_in,nlat_in,nlev_in,0:13,read_climoz))
     426         o3_in3bis(:,:,:,ib:ie,:)=o3_in3(1:nlon_in,:,:,ib:ie,:)
     427       ELSE
     428         ALLOCATE(o3_in3bis(0,0,0,0,read_climoz))
     429       ENDIF
     430       ALLOCATE(o3_regr_lonlat(1, nlat_ou, nlev_in, 0:13, read_climoz))
     431       
     432       CALL xios_send_field("tro3_in",o3_in3bis(:,:,:,:,:))
     433       CALL xios_recv_field("tro3_out",o3_regr_lonlat(1,:,:,:,:))
     434#endif
     435     ELSE
     436         
     437       !--- Regrid in longitude
     438        ALLOCATE(o3_regr_lon(nlon_ou, nlat_in, nlev_in, ie-ib+1, read_climoz))
     439        CALL regr_conserv(1, o3_in3, xs = lon_in_edge,                             &
     440                            xt = [boundslon_reg(1,west),boundslon_reg(:,east)],    &
     441                            vt = o3_regr_lon, slope = slopes(1,o3_in3, lon_in_edge))
     442        DEALLOCATE(o3_in3)
     443
     444        !--- Regrid in latitude: averaging with respect to SIN(lat) is
     445        !                        equivalent to weighting by COS(lat)
     446        !--- (inverted indices in "o3_regr_lonlat" because "rlatu" is decreasing)
     447        ALLOCATE(o3_regr_lonlat(nlon_ou, nlat_ou, nlev_in, 0:13, read_climoz))
     448        CALL regr_conserv(2, o3_regr_lon, xs = sinlat_in_edge,                     &
     449                        xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
     450                        vt = o3_regr_lonlat(:,nlat_ou:1:- 1,:,ib:ie,:),            &
     451                   slope = slopes(2,o3_regr_lon, sinlat_in_edge))
     452        DEALLOCATE(o3_regr_lon)
     453
     454     ENDIF
     455
     456     !--- Duplicate previous/next record(s) if they are not available
     457     IF(.NOT.lprev) o3_regr_lonlat(:,:,:, 0,:) = o3_regr_lonlat(:,:,:,12,:)
     458     IF(.NOT.lnext) o3_regr_lonlat(:,:,:,13,:) = o3_regr_lonlat(:,:,:, 1,:)
     459     
     460     !--- Regrid in time by linear interpolation:
     461     ALLOCATE(o3_out3(nlon_ou, nlat_ou, nlev_in, ntim_ou, read_climoz))
     462     IF(     interpt) CALL regr_lint(4,o3_regr_lonlat,tmidmonth,tmidday,o3_out3)
     463     IF(.NOT.interpt) o3_out3=o3_regr_lonlat
     464     DEALLOCATE(o3_regr_lonlat)
     465
     466     nlat_ou=nbp_lat
     467     IF (grid_type==unstructured) THEN
     468#ifdef CPP_XIOS
     469       CALL xios_send_field('o3_out',o3_out3)
     470       ndims=3
     471       ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
     472       CALL gather_mpi(o3_out3(1,:,:,:,:), o3_out3_glo)
     473#endif
     474     ENDIF
     475
     476    !--- Create the output file and get the variable IDs:
     477    CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
     478                     ndims, cal_ou)
     479
     480    IF (is_mpi_root) THEN
     481      !--- Write remaining coordinate variables:
     482      CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
     483      IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
     484      IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
     485
     486      !--- Write to file (the order of "rlatu" is inverted in the output file):
     487        IF (grid_type==unstructured) THEN
     488
     489          ALLOCATE(o3_out(nlat_ou, nlev_in, ntim_ou, read_climoz))
     490          DO i=1,klon_glo
     491            o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out3_glo(i,:,:,:)
     492          ENDDO
     493
     494          DO m = 1, read_climoz
     495            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m))
     496          END DO
     497         
     498        ELSE
     499          DO m = 1, read_climoz
     500            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out3(:,nlat_ou:1:-1,:,:,m))
     501          END DO
     502      ENDIF
     503      CALL NF95_CLOSE(fID_ou)
     504
     505
     506    ENDIF
     507
     508
     509    !=============================================================================
     510    ELSE                                                         !=== ZONAL FIELDS
     511    !=============================================================================
     512   
     513     IF (grid_type==unstructured) THEN
     514#ifdef CPP_XIOS
     515       nlat_ou=klon_mpi
     516
     517       IF (is_mpi_root) THEN
     518         ALLOCATE(o3_in2bis(8,nlat_in,nlev_in,0:13,read_climoz))
     519         o3_in2bis(:,:,:,ib:ie,:)=SPREAD(o3_in2,1,8)
     520       ELSE
     521         ALLOCATE(o3_in2bis(0,0,0,0,read_climoz))
     522       ENDIF
     523       ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
     524       CALL xios_send_field("tro3_in",o3_in2bis(:,:,:,:,:))
     525       CALL xios_recv_field("tro3_out",o3_regr_lat(:,:,:,:))
     526       IF(.NOT.lprev) o3_regr_lat(:,:, 0, :) = o3_regr_lat(:,:,12,:)
     527       IF(.NOT.lnext) o3_regr_lat(:,:,13, :) = o3_regr_lat(:,:, 1,:)
     528#endif       
     529     
     530     ELSE
     531        !--- Regrid in latitude: averaging with respect to SIN(lat) is
     532        !                        equivalent to weighting by COS(lat)
     533        !--- (inverted indices in "o3_regr_lat" because "rlatu" is decreasing)
     534        ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
     535        CALL regr_conserv(1, o3_in2, xs = sinlat_in_edge,                          &
     536                        xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
     537                        vt = o3_regr_lat(nlat_ou:1:- 1,:,ib:ie,:),                 &
     538                     slope = slopes(1,o3_in2, sinlat_in_edge))
     539        DEALLOCATE(o3_in2)
     540
     541        !--- Duplicate previous/next record(s) if they are not available
     542        IF(.NOT.lprev) o3_regr_lat(:,:, 0,:) = o3_regr_lat(:,:,12,:)
     543        IF(.NOT.lnext) o3_regr_lat(:,:,13,:) = o3_regr_lat(:,:, 1,:)
     544
     545     ENDIF
     546     
     547      !--- Regrid in time by linear interpolation:
     548      ALLOCATE(o3_out2(nlat_ou, nlev_in, ntim_ou, read_climoz))
     549      IF(     interpt) CALL regr_lint(3,o3_regr_lat, tmidmonth, tmidday, o3_out2)
     550      IF(.NOT.interpt) o3_out2=o3_regr_lat
     551      DEALLOCATE(o3_regr_lat)
     552
     553      nlat_ou=nbp_lat
     554   
     555      IF (grid_type==unstructured) THEN
     556        ndims=3
     557        ALLOCATE(o3_out2_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
     558        CALL gather_mpi(o3_out2, o3_out2_glo)
     559      ENDIF
     560     
     561      !--- Create the output file and get the variable IDs:
     562      CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
     563                         ndims, cal_ou)
     564
     565      IF (is_mpi_root) THEN
     566     
     567        !--- Write remaining coordinate variables:
     568        CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
     569        IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
     570        IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
     571
     572        IF (grid_type==unstructured) THEN
     573
     574          ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
     575          DO i=1,klon_glo
     576            o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out2_glo(i,:,:,:)
     577          ENDDO
     578
     579
     580          DO m = 1, read_climoz
     581            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m))
     582          END DO
     583        ELSE
     584          !--- Write to file (the order of "rlatu" is inverted in the output file):
     585          DO m = 1, read_climoz
     586            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out2(nlat_ou:1:-1,:,:,m))
     587          END DO
     588        ENDIF
     589       
     590        CALL NF95_CLOSE(fID_ou)
     591     
     592      ENDIF
     593
     594    !=============================================================================
    259595    END IF
    260     IF(lnext) THEN; sta(ndims)=1
    261       CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv))
    262       IF(l3D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt)
    263       IF(l2D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in2(          :,:,13,iv),sta,cnt)
    264       CALL handle_err(TRIM(msg)//" next", ncerr, fID_in_p)
    265     END IF
    266   END DO
    267   IF(lprev.OR.lnext) DEALLOCATE(sta,cnt)
    268   IF(lprev) CALL NF95_CLOSE(fID_in_m)
    269   IF(lnext) CALL NF95_CLOSE(fID_in_p)
    270 
    271   !--- Revert decreasing coordinates vector
    272   IF(l3D) THEN
    273     IF(ldec_lon) o3_in3(1:nlon_in,:,:,:,:) = o3_in3(nlon_in:1:-1,:,:,:,:)
    274     IF(ldec_lat) o3_in3 = o3_in3(:,nlat_in:1:-1,:,:,:)
    275     IF(ldec_lev) o3_in3 = o3_in3(:,:,nlev_in:1:-1,:,:)
    276     !--- Shift values for longitude and duplicate some longitudes slices
    277     o3_in3(1:nlon_in,:,:,:,:)=CSHIFT(o3_in3(1:nlon_in,:,:,:,:),SHIFT=dx1,DIM=1)
    278     o3_in3(nlon_in+1:nlon_in+dx2,:,:,:,:)=o3_in3(1:dx2,:,:,:,:)
    279   ELSE
    280     IF(ldec_lat) o3_in2 = o3_in2(  nlat_in:1:-1,:,:,:)
    281     IF(ldec_lev) o3_in2 = o3_in2(  :,nlev_in:1:-1,:,:)
    282   END IF
    283 
    284  !--- Deal with missing values
    285   DO m=1, read_climoz
    286     WRITE(msg,'(a,i0)')"regr_lat_time_climoz: field Nr.",m
    287     IF(NF90_GET_ATT(fID_in,vID_in(m),"missing_value",NaN)/= NF90_NOERR) THEN
    288       IF(NF90_GET_ATT(fID_in, vID_in(m),"_FillValue",NaN)/= NF90_NOERR) THEN
    289         WRITE(lunout,*)TRIM(msg)//": no missing value attribute found."; CYCLE
    290       END IF
    291     END IF
    292     WRITE(lunout,*)TRIM(msg)//": missing value attribute found."
    293     WRITE(lunout,*)"Trying to fill in NaNs ; a full field would be better."
    294 
    295     !--- Check top layer contains no NaNs & search NaNs from top to ground
    296     msg=TRIM(sub)//": NaNs in top layer !"
    297     IF(l3D) THEN
    298       IF(ANY(o3_in3(:,:,1,:,m)==NaN)) CALL abort_physic(sub,msg,1)
    299       DO k = 2,nlev_in
    300         WHERE(o3_in3(:,:,k,:,m)==NaN) o3_in3(:,:,k,:,m)=o3_in3(:,:,k-1,:,m)
    301       END DO
    302     ELSE
    303       IF(ANY(o3_in2(  :,1,:,m)==NaN)) THEN
    304         WRITE(lunout,*)msg
    305         !--- Fill in latitudes where all values are missing
    306         DO l=1,nmth_in
    307           !--- Next to south pole
    308           j=1;       DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
    309           IF(j>1) &
    310             o3_in2(:j-1,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=j-1)
    311           !--- Next to north pole
    312           j=nlat_in; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
    313           IF(j<nlat_in) &
    314             o3_in2(j+1:,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=nlat_in-j)
    315         END DO
    316       END IF
    317 
    318       !--- Fill in high latitudes missing values
    319       !--- Highest level been filled-in, so has always valid values.
    320       DO k = 2,nlev_in
    321         WHERE(o3_in2(:,k,:,m)==NaN) o3_in2(:,k,:,m)=o3_in2(:,k-1,:,m)
    322       END DO
    323     END IF
    324   END DO
    325   CALL NF95_CLOSE(fID_in)
    326 
    327   !=============================================================================
    328   IF(l3D) THEN                                                   !=== 3D FIELDS
    329   !=============================================================================
    330     !--- Regrid in longitude
    331     ALLOCATE(o3_regr_lon(nlon_ou, nlat_in, nlev_in, ie-ib+1, read_climoz))
    332     CALL regr_conserv(1, o3_in3, xs = lon_in_edge,                             &
    333                         xt = [boundslon_reg(1,west),boundslon_reg(:,east)],    &
    334                         vt = o3_regr_lon, slope = slopes(1,o3_in3, lon_in_edge))
    335     DEALLOCATE(o3_in3)
    336 
    337     !--- Regrid in latitude: averaging with respect to SIN(lat) is
    338     !                        equivalent to weighting by COS(lat)
    339     !--- (inverted indices in "o3_regr_lonlat" because "rlatu" is decreasing)
    340     ALLOCATE(o3_regr_lonlat(nlon_ou, nlat_ou, nlev_in, 0:13, read_climoz))
    341     CALL regr_conserv(2, o3_regr_lon, xs = sinlat_in_edge,                     &
    342                     xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
    343                     vt = o3_regr_lonlat(:,nlat_ou:1:- 1,:,ib:ie,:),            &
    344                  slope = slopes(2,o3_regr_lon, sinlat_in_edge))
    345     DEALLOCATE(o3_regr_lon)
    346 
    347     !--- Duplicate previous/next record(s) if they are not available
    348     IF(.NOT.lprev) o3_regr_lonlat(:,:,:, 0,:) = o3_regr_lonlat(:,:,:,12,:)
    349     IF(.NOT.lnext) o3_regr_lonlat(:,:,:,13,:) = o3_regr_lonlat(:,:,:, 1,:)
    350 
    351     !--- Regrid in time by linear interpolation:
    352     ALLOCATE(o3_out3(nlon_ou, nlat_ou, nlev_in, ntim_ou, read_climoz))
    353     IF(     interpt) CALL regr_lint(4,o3_regr_lonlat,tmidmonth,tmidday,o3_out3)
    354     IF(.NOT.interpt) o3_out3=o3_regr_lonlat
    355     DEALLOCATE(o3_regr_lonlat)
    356 
    357     !--- Write to file (the order of "rlatu" is inverted in the output file):
    358     DO m = 1, read_climoz
    359       CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out3(:,nlat_ou:1:-1,:,:,m))
    360     END DO
    361 
    362   !=============================================================================
    363   ELSE                                                         !=== ZONAL FIELDS
    364   !=============================================================================
    365     !--- Regrid in latitude: averaging with respect to SIN(lat) is
    366     !                        equivalent to weighting by COS(lat)
    367     !--- (inverted indices in "o3_regr_lat" because "rlatu" is decreasing)
    368     ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
    369     CALL regr_conserv(1, o3_in2, xs = sinlat_in_edge,                          &
    370                     xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
    371                     vt = o3_regr_lat(nlat_ou:1:- 1,:,ib:ie,:),                 &
    372                  slope = slopes(1,o3_in2, sinlat_in_edge))
    373     DEALLOCATE(o3_in2)
    374 
    375     !--- Duplicate previous/next record(s) if they are not available
    376     IF(.NOT.lprev) o3_regr_lat(:,:, 0,:) = o3_regr_lat(:,:,12,:)
    377     IF(.NOT.lnext) o3_regr_lat(:,:,13,:) = o3_regr_lat(:,:, 1,:)
    378 
    379     !--- Regrid in time by linear interpolation:
    380     ALLOCATE(o3_out2(nlat_ou, nlev_in, ntim_ou, read_climoz))
    381     IF(     interpt) CALL regr_lint(3,o3_regr_lat, tmidmonth, tmidday, o3_out2)
    382     IF(.NOT.interpt) o3_out2=o3_regr_lat
    383     DEALLOCATE(o3_regr_lat)
    384 
    385     !--- Write to file (the order of "rlatu" is inverted in the output file):
    386     DO m = 1, read_climoz
    387       CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out2(nlat_ou:1:-1,:,:,m))
    388     END DO
    389 
    390   !=============================================================================
    391   END IF
    392   !=============================================================================
    393 
    394   CALL NF95_CLOSE(fID_ou)
    395 
     596    !=============================================================================
     597
     598    IF (is_mpi_root) CALL NF95_CLOSE(fID_in)
     599
     600  ENDIF ! is_omp_master
     601
     602  first=.FALSE.
    396603END SUBROUTINE regr_horiz_time_climoz
    397604!
    … …  
    408615!-------------------------------------------------------------------------------
    409616  USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
     617  USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
     618  USE mod_phys_lmdz_para, ONLY: is_mpi_root
     619  USE mod_grid_phy_lmdz, ONLY: klon_glo
     620!
    410621!-------------------------------------------------------------------------------
    411622! Arguments:
    … …  
    419630  INTEGER :: dlonID, dlatID, dlevID, dtimID, dIDs(4)
    420631  INTEGER :: vlonID, vlatID, ncerr,  is
     632  REAL,ALLOCATABLE    :: latitude_glo_(:)
    421633  CHARACTER(LEN=80) :: sub
    422 !-------------------------------------------------------------------------------
    423   sub="prepare_out"
    424   WRITE(lunout,*)"CALL sequence information: "//TRIM(sub)
    425   CALL NF95_CREATE("climoz_LMDZ.nc", NF90_clobber, fID_ou)
     634  INTEGER :: i
     635
     636
     637!-------------------------------------------------------------------------------
     638 
     639  IF (is_mpi_root) THEN 
     640    sub="prepare_out"
     641    WRITE(lunout,*)"CALL sequence information: "//TRIM(sub)
     642    CALL NF95_CREATE("climoz_LMDZ.nc", NF90_clobber, fID_ou)
    426643
    427644  !--- Dimensions:
    428   IF(ndims==4) &
    429   CALL NF95_DEF_DIM(fID_ou, "rlonv", nlon_ou, dlonID)
    430   CALL NF95_DEF_DIM(fID_ou, "rlatu", nlat_ou, dlatID)
    431   CALL NF95_DEF_DIM(fID_ou, "plev",  nlev_in, dlevID)
    432   CALL NF95_DEF_DIM(fID_ou, "time",  ntim_ou, dtimID)
    433 
    434   !--- Define coordinate variables:
    435   IF(ndims==4) &
    436   CALL NF95_DEF_VAR(fID_ou, "rlonv", NF90_FLOAT, dlonID, vlonID)
    437   CALL NF95_DEF_VAR(fID_ou, "rlatu", NF90_FLOAT, dlatID, vlatID)
    438   CALL NF95_DEF_VAR(fID_ou, "plev",  NF90_FLOAT, dlevID, vlevID)
    439   CALL NF95_DEF_VAR(fID_ou, "time",  NF90_FLOAT, dtimID, vtimID)
    440   IF(ndims==4) &
    441   CALL NF95_PUT_ATT(fID_ou, vlonID, "units", "degrees_east")
    442   CALL NF95_PUT_ATT(fID_ou, vlatID, "units", "degrees_north")
    443   CALL NF95_PUT_ATT(fID_ou, vlevID, "units", "millibar")
    444   CALL NF95_PUT_ATT(fID_ou, vtimID, "units", "days since 2000-1-1")
    445   IF(ndims==4) &
    446   CALL NF95_PUT_ATT(fID_ou, vlonID, "standard_name", "longitude")
    447   CALL NF95_PUT_ATT(fID_ou, vlatID, "standard_name", "latitude")
    448   CALL NF95_PUT_ATT(fID_ou, vlevID, "standard_name", "air_pressure")
    449   CALL NF95_PUT_ATT(fID_ou, vtimID, "standard_name", "time")
    450   CALL NF95_PUT_ATT(fID_ou, vlevID, "long_name",     "air pressure")
    451   CALL NF95_PUT_ATT(fID_ou, vtimID, "calendar",      cal_ou)
     645    IF(ndims==4) &
     646    CALL NF95_DEF_DIM(fID_ou, "rlonv", nlon_ou, dlonID)
     647    CALL NF95_DEF_DIM(fID_ou, "rlatu", nlat_ou, dlatID)
     648    CALL NF95_DEF_DIM(fID_ou, "plev",  nlev_in, dlevID)
     649    CALL NF95_DEF_DIM(fID_ou, "time",  ntim_ou, dtimID)
     650
     651    !--- Define coordinate variables:
     652    IF(ndims==4) &
     653    CALL NF95_DEF_VAR(fID_ou, "rlonv", NF90_FLOAT, dlonID, vlonID)
     654    CALL NF95_DEF_VAR(fID_ou, "rlatu", NF90_FLOAT, dlatID, vlatID)
     655    CALL NF95_DEF_VAR(fID_ou, "plev",  NF90_FLOAT, dlevID, vlevID)
     656    CALL NF95_DEF_VAR(fID_ou, "time",  NF90_FLOAT, dtimID, vtimID)
     657    IF(ndims==4) &
     658    CALL NF95_PUT_ATT(fID_ou, vlonID, "units", "degrees_east")
     659    CALL NF95_PUT_ATT(fID_ou, vlatID, "units", "degrees_north")
     660    CALL NF95_PUT_ATT(fID_ou, vlevID, "units", "millibar")
     661    CALL NF95_PUT_ATT(fID_ou, vtimID, "units", "days since 2000-1-1")
     662    IF(ndims==4) &
     663    CALL NF95_PUT_ATT(fID_ou, vlonID, "standard_name", "longitude")
     664    CALL NF95_PUT_ATT(fID_ou, vlatID, "standard_name", "latitude")
     665    CALL NF95_PUT_ATT(fID_ou, vlevID, "standard_name", "air_pressure")
     666    CALL NF95_PUT_ATT(fID_ou, vtimID, "standard_name", "time")
     667    CALL NF95_PUT_ATT(fID_ou, vlevID, "long_name",     "air pressure")
     668    CALL NF95_PUT_ATT(fID_ou, vtimID, "calendar",      cal_ou)
    452669
    453670  !--- Define the main variables:
    454   IF(ndims==3) dIDs(1:3) = [ dlatID, dlevID, dtimID]
    455   IF(ndims==4) dIDs=[dlonID, dlatID, dlevID, dtimID]
    456   CALL NF95_DEF_VAR(fID_ou, vars_in(1), NF90_FLOAT, dIDs(1:ndims), vID_ou(1))
    457   CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "long_name", "ozone mole fraction")
    458   CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "standard_name", "mole_fraction_of_ozone&
     671    IF(ndims==3) dIDs(1:3) = [ dlatID, dlevID, dtimID]
     672    IF(ndims==4) dIDs=[dlonID, dlatID, dlevID, dtimID]
     673    CALL NF95_DEF_VAR(fID_ou, vars_in(1), NF90_FLOAT, dIDs(1:ndims), vID_ou(1))
     674    CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "long_name", "ozone mole fraction")
     675    CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "standard_name", "mole_fraction_of_ozone&
    459676      &_in_air")
    460   IF(SIZE(vID_ou) == 2) THEN
    461     CALL NF95_DEF_VAR(fID_ou, vars_in(2), NF90_FLOAT, dIDs(1:ndims), vID_ou(2))
    462     CALL NF95_PUT_ATT(fID_ou, vID_ou(2), "long_name","ozone mole fraction in da&
    463       &ylight")
    464   END IF
     677    IF(SIZE(vID_ou) == 2) THEN
     678      CALL NF95_DEF_VAR(fID_ou, vars_in(2), NF90_FLOAT, dIDs(1:ndims), vID_ou(2))
     679      CALL NF95_PUT_ATT(fID_ou, vID_ou(2), "long_name","ozone mole fraction in da&
     680        &ylight")
     681    END IF
    465682
    466683  !--- Global attributes:
    467684  ! The following commands, copying attributes, may fail. That is OK.
    468685  ! It should just mean that the attribute is not defined in the input file.
    469   CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"Conventions",fID_ou,NF90_GLOBAL, ncerr)
    470   CALL handle_err_copy_att("Conventions")
    471   CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"title",      fID_ou,NF90_GLOBAL, ncerr)
    472   CALL handle_err_copy_att("title")
    473   CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"institution",fID_ou,NF90_GLOBAL, ncerr)
    474   CALL handle_err_copy_att("institution")
    475   CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"source",     fID_ou,NF90_GLOBAL, ncerr)
    476   CALL handle_err_copy_att("source")
    477   CALL NF95_PUT_ATT (fID_ou,NF90_GLOBAL,"comment", "Regridded for LMDZ")
    478   CALL NF95_ENDDEF(fID_ou)
    479 
    480   !--- Write one of the coordinate variables:
    481   IF(ndims==4) CALL NF95_PUT_VAR(fID_ou, vlonID, lon_reg/deg2rad)
    482   CALL NF95_PUT_VAR(fID_ou, vlatID, lat_reg(nlat_ou:1:-1)/deg2rad)
    483   !    (convert from rad to degrees and sort in ascending order)
    484 
     686    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"Conventions",fID_ou,NF90_GLOBAL, ncerr)
     687    CALL handle_err_copy_att("Conventions")
     688    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"title",      fID_ou,NF90_GLOBAL, ncerr)
     689    CALL handle_err_copy_att("title")
     690    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"institution",fID_ou,NF90_GLOBAL, ncerr)
     691    CALL handle_err_copy_att("institution")
     692    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"source",     fID_ou,NF90_GLOBAL, ncerr)
     693    CALL handle_err_copy_att("source")
     694    CALL NF95_PUT_ATT (fID_ou,NF90_GLOBAL,"comment", "Regridded for LMDZ")
     695    CALL NF95_ENDDEF(fID_ou)
     696
     697    IF (grid_type==unstructured) THEN
     698      ALLOCATE(latitude_glo_(klon_glo))
     699      DO i=1,klon_glo
     700        latitude_glo_(ind_cell_glo_glo(i))=latitude_glo(i)
     701      ENDDO
     702      CALL NF95_PUT_VAR(fID_ou, vlatID, latitude_glo_)
     703    ELSE
     704      !--- Write one of the coordinate variables:
     705      IF(ndims==4) CALL NF95_PUT_VAR(fID_ou, vlonID, lon_reg/deg2rad)
     706      CALL NF95_PUT_VAR(fID_ou, vlatID, lat_reg(nlat_ou:1:-1)/deg2rad)
     707    !    (convert from rad to degrees and sort in ascending order)
     708    ENDIF
     709  ENDIF
     710 
    485711CONTAINS
    486712

  • LMDZ6/branches/Ocean_skin/libf/phylmd/regr_pr_time_av_m.F90

    r3141 r3605  
    118118  USE assert_m,       ONLY: assert
    119119  USE assert_eq_m,    ONLY: assert_eq
    120   USE comvert_mod,    ONLY: scaleheight
     120!!  USE comvert_mod,    ONLY: scaleheight
    121121  USE interpolation,  ONLY: locate
    122122  USE regr_conserv_m, ONLY: regr_conserv
    123123  USE regr_lint_m,    ONLY: regr_lint
    124124  USE slopes_m,       ONLY: slopes
    125   USE mod_phys_lmdz_mpi_data,       ONLY: is_mpi_root
    126   USE mod_grid_phy_lmdz, ONLY: nlon=>nbp_lon, nlat=>nbp_lat, nlev_ou=>nbp_lev
    127   USE mod_phys_lmdz_transfert_para, ONLY: scatter2d, scatter
     125  USE mod_phys_lmdz_para,           ONLY: is_mpi_root,is_master
     126  USE mod_grid_phy_lmdz,            ONLY: nlon=>nbp_lon, nlat=>nbp_lat, nlev_ou=>nbp_lev, klon_glo, grid_type, unstructured
     127  USE mod_phys_lmdz_transfert_para, ONLY: scatter2d, scatter, gather
    128128  USE phys_cal_mod,                 ONLY: calend, year_len, days_elapsed, jH_cur
     129  USE geometry_mod,                 ONLY: ind_cell_glo
    129130!-------------------------------------------------------------------------------
    130131! Arguments:
    … …  
    175176    v2i(klon,SIZE(Pre_in)-1,SIZE(nam)), &     !--- v2 in Ploc=='I' case
    176177    v2c(klon,SIZE(Pre_in)  ,SIZE(nam))        !--- v2 in Ploc=='C' case
     178  INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
    177179  LOGICAL :: ll
    178180!--- For debug
    … …  
    247249      IF(lO3Tfile) ot1=al*otm+(1.-al)*otp
    248250    END IF
     251  ELSE
     252    IF (lfirst) ALLOCATE(v1(0,0,0,0))
    249253  END IF
    250254  !$OMP END MASTER
     255  !$OMP BARRIER
    251256  IF(lfirst) THEN
    252257    lfirst=.FALSE.;       CALL bcast(lfirst)
    … …  
    255260    CALL bcast(lO3Tfile); CALL bcast(linterp)
    256261  END IF
     262 
     263  IF (is_master) THEN
     264    ALLOCATE(ind_cell_glo_glo(klon_glo))
     265  ELSE
     266    ALLOCATE(ind_cell_glo_glo(0))
     267  ENDIF
     268  CALL gather(ind_cell_glo,ind_cell_glo_glo)
     269  IF (is_master .AND. grid_type==unstructured) v1(:,:,:,:)=v1(:,ind_cell_glo_glo(:),:,:)
     270 
    257271  CALL scatter2d(v1,v2)
    258   IF(lPrSfile) CALL scatter2d(pg1,Pgnd_in)
    259   IF(lPrTfile) CALL scatter2d(pt1,Ptrp_in)
    260   IF(lO3Tfile) CALL scatter2d(ot1,Otrp_in)
     272
     273  !--- No "ps" in input file => assumed to be equal to current LMDZ ground press
     274  IF(lPrSfile) THEN
     275    IF (is_master .AND. grid_type==unstructured) pg1(:,:)=pg1(:,ind_cell_glo_glo(:))
     276    CALL scatter2d(pg1,Pgnd_in)
     277  ELSE
     278    Pgnd_in=Pre_ou(:,1)
     279  END IF
     280
     281  IF(lPrTfile) THEN
     282    IF (is_master .AND. grid_type==unstructured) pt1(:,:)=pt1(:,ind_cell_glo_glo(:))
     283    CALL scatter2d(pt1,Ptrp_in)
     284  ENDIF
     285
     286  IF(lO3Tfile) THEN
     287    IF (is_master .AND. grid_type==unstructured) ot1(:,:)=ot1(:,ind_cell_glo_glo(:))
     288    CALL scatter2d(ot1,Otrp_in)
     289  ENDIF
    261290  !--- No ground pressure in input file => choose it to be the one of LMDZ
    262291  IF(lAdjTro.AND..NOT.lPrSfile) Pgnd_in(:)=Pgrnd_ou(:)
    263  
    264 !-------------------------------------------------------------------------------
    265   IF(.NOT.lAdjTro) THEN       !--- REGRID IN PRESSURE ; NO TROPOPAUSE ADJUSTMENT
    266 !-------------------------------------------------------------------------------
     292
     293  !--- REGRID IN PRESSURE ; 3rd index inverted because "paprs" is decreasing
     294  IF(.NOT.lAdjTro) THEN
    267295    DO i=1,klon
    268296      Pres_ou=Pre_ou(i,SIZE(Pre_ou,2):1:-1)   !--- pplay & paprs are decreasing

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/aeropt_6bands_rrtm.F90

    r3288 r3605  
    66     tau_allaer, piz_allaer, &
    77     cg_allaer, m_allaer_pi, &
    8      flag_aerosol, flag_bc_internal_mixture, zrho )
     8     flag_aerosol, flag_bc_internal_mixture, zrho, ok_volcan )
    99
    1010  USE dimphy
    … …  
    3232  LOGICAL,                        INTENT(IN)  :: flag_bc_internal_mixture
    3333  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: zrho
     34  LOGICAL,                        INTENT(IN)  :: ok_volcan ! volcanic diags
    3435  !
    3536  ! Output arguments:
    … …  
    794795         cg_allaer(i,k,2,inu)=MIN(MAX(cg_allaer(i,k,2,inu),0.0),1.0)
    795796
    796 !--natural aerosol
    797 !--ASBCM aerosols take _pi value because of internal mixture option
    798          tau_allaer(i,k,1,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ &
    799                                tau_ae_pi(i,k,id_ASBCM_phy,inu)+tau_ae_pi(i,k,id_AIBCM_phy,inu)+   &
    800                                tau_ae_pi(i,k,id_ASPOMM_phy,inu)+tau_ae_pi(i,k,id_AIPOMM_phy,inu)+ &
    801                                tau_ae_pi(i,k,id_ASSSM_phy,inu)+tau_ae_pi(i,k,id_CSSSM_phy,inu)+   &
    802                                tau_ae_pi(i,k,id_SSSSM_phy,inu)+ tau_ae_pi(i,k,id_CIDUSTM_phy,inu)
    803          tau_allaer(i,k,1,inu)=MAX(tau_allaer(i,k,1,inu),tau_min)
    804 
    805          piz_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+   &
    806                                 tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+   &
    807                                 tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)+  &
    808                                 tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+     &
    809                                 tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+   &
    810                                 tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+   &
    811                                 tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+     &
    812                                 tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+     &
    813                                 tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+     &
    814                                 tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
    815                                 /tau_allaer(i,k,1,inu)
    816          piz_allaer(i,k,1,inu)=MIN(MAX(piz_allaer(i,k,1,inu),0.01),1.0)
    817          IF (tau_allaer(i,k,1,inu).LE.tau_min) piz_allaer(i,k,1,inu)=1.0
    818 
    819          cg_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+    &
    820                                tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)*cg_ae(i,k,id_CSSO4M_phy,inu)+    &
    821                                tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)*cg_ae_pi(i,k,id_ASBCM_phy,inu)+ &
    822                                tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu)+       &
    823                                tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)+    &
    824                                tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu)+    &
    825                                tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)*cg_ae(i,k,id_ASSSM_phy,inu)+       &
    826                                tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu)+       &
    827                                tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu)+       &
    828                                tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)*cg_ae(i,k,id_CIDUSTM_phy,inu))/ &
    829                                (tau_allaer(i,k,1,inu)*piz_allaer(i,k,1,inu))
    830          cg_allaer(i,k,1,inu)=MIN(MAX(cg_allaer(i,k,1,inu),0.0),1.0)
    831 
     797         IF (.NOT. ok_volcan) THEN
     798!
     799!--this is the default case
     800!--in this case, index 1 of tau_allaer contains natural aerosols only
     801!--because the objective is to perform the double radiation call with and without anthropogenic aerosols
     802!
     803           tau_allaer(i,k,1,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ &
     804                                 tau_ae_pi(i,k,id_ASBCM_phy,inu)+tau_ae_pi(i,k,id_AIBCM_phy,inu)+   &
     805                                 tau_ae_pi(i,k,id_ASPOMM_phy,inu)+tau_ae_pi(i,k,id_AIPOMM_phy,inu)+ &
     806                                 tau_ae_pi(i,k,id_ASSSM_phy,inu)+tau_ae_pi(i,k,id_CSSSM_phy,inu)+   &
     807                                 tau_ae_pi(i,k,id_SSSSM_phy,inu)+ tau_ae_pi(i,k,id_CIDUSTM_phy,inu)
     808           tau_allaer(i,k,1,inu)=MAX(tau_allaer(i,k,1,inu),tau_min)
     809         
     810           piz_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+   &
     811                                  tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+   &
     812                                  tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)+  &
     813                                  tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+     &
     814                                  tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+   &
     815                                  tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+   &
     816                                  tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+     &
     817                                  tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+     &
     818                                  tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+     &
     819                                  tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
     820                                  /tau_allaer(i,k,1,inu)
     821           piz_allaer(i,k,1,inu)=MIN(MAX(piz_allaer(i,k,1,inu),0.01),1.0)
     822           IF (tau_allaer(i,k,1,inu).LE.tau_min) piz_allaer(i,k,1,inu)=1.0
     823         
     824           cg_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+    &
     825                                 tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)*cg_ae(i,k,id_CSSO4M_phy,inu)+    &
     826                                 tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)*cg_ae_pi(i,k,id_ASBCM_phy,inu)+ &
     827                                 tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu)+       &
     828                                 tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)+    &
     829                                 tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu)+    &
     830                                 tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)*cg_ae(i,k,id_ASSSM_phy,inu)+       &
     831                                 tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu)+       &
     832                                 tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu)+       &
     833                                 tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)*cg_ae(i,k,id_CIDUSTM_phy,inu))/ &
     834                                 (tau_allaer(i,k,1,inu)*piz_allaer(i,k,1,inu))
     835           cg_allaer(i,k,1,inu)=MIN(MAX(cg_allaer(i,k,1,inu),0.0),1.0)
     836!
     837         ELSE
     838!
     839!--this is the case for VOLMIP
     840!--in this case index 1 of tau_allaer contains all (natural+anthropogenic) aerosols (same as index 2 above)
     841!--but stratospheric aerosols will not be added in rrtm/readaerosolstrato2 as
     842!--the objective is to have the double radiation call with and without stratospheric aerosols
     843!
     844           tau_allaer(i,k,1,inu)=tau_allaer(i,k,2,inu)
     845           
     846           piz_allaer(i,k,1,inu)=piz_allaer(i,k,2,inu)
     847           
     848           cg_allaer(i,k,1,inu) =cg_allaer(i,k,2,inu)
     849!
     850         ENDIF
    832851        ENDDO
    833852      ENDDO

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/radlsw.F90

    r2192 r3605  
    502502    ELSEIF (NRADLP == 3) THEN 
    503503! one uses the cloud droplet radius from newmicro
    504 ! IKL or JK ?? - I think IKL but needs to be verified
     504! IKL or JK ?? - I think IKL but needs to be verified > ref_liq_i
     505! (inverted) is used in the call of RECMWF_AERO in radlwsw_m.F90,
     506! so everything is fine - JBM 6/2019
    505507        ZRADLP(JL)=PREF_LIQ(JL,IKL)
    506508    ENDIF 

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/readaerosol_optic_rrtm.F90

    r3333 r3605  
    11! $Id$
    22!
    3 SUBROUTINE readaerosol_optic_rrtm(debut, aerosol_couple, ok_alw, &
     3SUBROUTINE readaerosol_optic_rrtm(debut, aerosol_couple, ok_alw, ok_volcan, &
    44     new_aod, flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, &
    55     pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
    … …  
    3232  LOGICAL, INTENT(IN)                      :: aerosol_couple
    3333  LOGICAL, INTENT(IN)                      :: ok_alw
     34  LOGICAL, INTENT(IN)                      :: ok_volcan
    3435  LOGICAL, INTENT(IN)                      :: new_aod
    3536  INTEGER, INTENT(IN)                      :: flag_aerosol
    … …  
    313314       tau_aero, piz_aero, cg_aero, &
    314315       m_allaer_pi, flag_aerosol,   &
    315        flag_bc_internal_mixture, zrho )
     316       flag_bc_internal_mixture, zrho, ok_volcan )
    316317
    317318  ! aeropt_5wv only for validation and diagnostics

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/readaerosolstrato1_rrtm.F90

    r2744 r3605  
    22! $Id: readaerosolstrato1_rrtm.F90 2526 2016-05-26 22:13:40Z oboucher $
    33!
     4
    45SUBROUTINE readaerosolstrato1_rrtm(debut)
    56
    … …  
    910
    1011    USE phys_cal_mod, ONLY : mth_cur
    11     USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo
    12     USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
    13     USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
     12    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo, grid_type, unstructured
    1413    USE mod_phys_lmdz_para
    1514    USE phys_state_var_mod
    … …  
    1918    USE YOERAD, ONLY : NLW
    2019    USE YOMCST
     20#ifdef CPP_XIOS
     21    USE xios
     22#endif
    2123
    2224    IMPLICIT NONE
    … …  
    4547    REAL, ALLOCATABLE:: tauaerstrat_mois(:, :, :)
    4648    REAL, ALLOCATABLE:: tauaerstrat_mois_glo(:, :)
     49    REAL, ALLOCATABLE:: tauaerstrat_mpi(:, :)
    4750
    4851! For NetCDF:
    … …  
    102105    n_lat = size(latitude)
    103106    print *, 'LAT aerosol strato=', n_lat, latitude
    104     IF (n_lat.NE.nbp_lat) THEN
    105        print *,'Le nombre de lat n est pas egal a nbp_lat'
    106        STOP
    107     ENDIF
    108 
     107
     108    IF (grid_type/=unstructured) THEN
     109      IF (n_lat.NE.nbp_lat) THEN
     110         print *,'Le nombre de lat n est pas egal a nbp_lat'
     111         STOP
     112      ENDIF
     113    ENDIF
     114   
    109115    CALL nf95_inq_varid(ncid_in, "LON", varid)
    110116    CALL nf95_gw_var(ncid_in, varid, longitude)
    111117    n_lon = size(longitude)
    112118    print *, 'LON aerosol strato=', n_lon, longitude
    113     IF (n_lon.NE.nbp_lon) THEN
    114        print *,'Le nombre de lon n est pas egal a nbp_lon'
    115        STOP
    116     ENDIF
    117 
     119
     120    IF (grid_type/=unstructured) THEN
     121      IF (n_lon.NE.nbp_lon) THEN
     122         print *,'Le nombre de lon n est pas egal a nbp_lon'
     123         STOP
     124      ENDIF
     125    ENDIF
     126   
     127   
    118128    CALL nf95_inq_varid(ncid_in, "TIME", varid)
    119129    CALL nf95_gw_var(ncid_in, varid, time)
    … …  
    144154!---reduce to a klon_glo grid
    145155    CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo)
    146 
     156   
     157    ELSE
     158      ALLOCATE(tauaerstrat_mois(0,0,0))
    147159    ENDIF !--is_mpi_root and is_omp_root
    148160
    … …  
    153165
    154166!--scatter on all proc
    155     CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
    156 
     167   
     168    IF (grid_type==unstructured) THEN
     169#ifdef CPP_XIOS
     170      IF (is_omp_master) THEN
     171        ALLOCATE(tauaerstrat_mpi(klon_mpi,klev))
     172        CALL xios_send_field("taustrat_in",tauaerstrat_mois)
     173        CALL xios_recv_field("taustrat_out",tauaerstrat_mpi)
     174      ELSE
     175        ALLOCATE(tauaerstrat_mpi(0,0))
     176      ENDIF
     177      CALL scatter_omp(tauaerstrat_mpi,tau_aer_strat)
     178#endif
     179    ELSE 
     180      CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
     181    ENDIF
     182   
    157183    IF (is_mpi_root.AND.is_omp_root) THEN
    158184!

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/readaerosolstrato2_rrtm.F90

    r2744 r3605  
    22! $Id: readaerosolstrato2_rrtm.F90 2526 2016-05-26 22:13:40Z oboucher $
    33!
    4 SUBROUTINE readaerosolstrato2_rrtm(debut)
     4SUBROUTINE readaerosolstrato2_rrtm(debut, ok_volcan)
    55
    66    USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, &
    … …  
    99
    1010    USE phys_cal_mod, ONLY : mth_cur
    11     USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo
    12     USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
    13     USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
     11    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo, grid_type, unstructured
     12    USE mod_phys_lmdz_mpi_data
     13    USE mod_phys_lmdz_omp_data
    1414    USE mod_phys_lmdz_para
    1515    USE phys_state_var_mod
    … …  
    1919    USE YOERAD, ONLY : NLW
    2020    USE YOMCST
     21#ifdef CPP_XIOS
     22    USE xios
     23#endif
    2124
    2225    IMPLICIT NONE
    … …  
    2932! Variable input
    3033    LOGICAL, INTENT(IN) ::  debut
     34    LOGICAL, INTENT(IN) ::  ok_volcan !activate volcanic diags
    3135
    3236! Variables locales
    … …  
    6569    REAL, ALLOCATABLE:: cgaerstrat_mois_glo(:, :, :)
    6670    REAL, ALLOCATABLE:: taulwaerstrat_mois_glo(:, :, :)
     71    REAL, ALLOCATABLE:: tauaerstrat_mpi(:, :, :)
     72    REAL, ALLOCATABLE:: pizaerstrat_mpi(:, :, :)
     73    REAL, ALLOCATABLE:: cgaerstrat_mpi(:, :, :)
     74    REAL, ALLOCATABLE:: taulwaerstrat_mpi(:, :, :)
    6775
    6876! For NetCDF:
    … …  
    107115        CALL nf95_gw_var(ncid_in, varid, latitude)
    108116        n_lat = size(latitude)
    109         IF (n_lat.NE.nbp_lat) THEN
    110            print *, 'latitude=', n_lat, nbp_lat
    111            abort_message='Le nombre de lat n est pas egal a nbp_lat'
    112            CALL abort_physic(modname,abort_message,1)
     117
     118        IF (grid_type/=unstructured) THEN
     119           IF (n_lat.NE.nbp_lat) THEN
     120             print *, 'latitude=', n_lat, nbp_lat
     121             abort_message='Le nombre de lat n est pas egal a nbp_lat'
     122             CALL abort_physic(modname,abort_message,1)
     123           ENDIF
    113124        ENDIF
    114125
    … …  
    134145        ALLOCATE(cgaerstrat(n_lat, n_lev, n_wav, n_month))
    135146
    136         ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
    137         ALLOCATE(pizaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
    138         ALLOCATE(cgaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
    139 
    140         ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev, n_wav))
    141         ALLOCATE(pizaerstrat_mois_glo(klon_glo, n_lev, n_wav))
    142         ALLOCATE(cgaerstrat_mois_glo(klon_glo, n_lev, n_wav))
    143 
    144147!--reading stratospheric aerosol tau per layer
    145148        CALL nf95_inq_varid(ncid_in, "TAU_SUN", varid)
    … …  
    159162        CALL nf95_close(ncid_in)
    160163
     164       
     165        IF (grid_type/=unstructured) THEN
     166          ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
     167          ALLOCATE(pizaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
     168          ALLOCATE(cgaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
     169
     170          ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev, n_wav))
     171          ALLOCATE(pizaerstrat_mois_glo(klon_glo, n_lev, n_wav))
     172          ALLOCATE(cgaerstrat_mois_glo(klon_glo, n_lev, n_wav))
    161173!--select the correct month
    162174!--and copy into 1st longitude
    163         tauaerstrat_mois(1,:,:,:) = tauaerstrat(:,:,:,mth_cur)
    164         pizaerstrat_mois(1,:,:,:) = pizaerstrat(:,:,:,mth_cur)
    165         cgaerstrat_mois(1,:,:,:)  = cgaerstrat(:,:,:,mth_cur)
     175          tauaerstrat_mois(1,:,:,:) = tauaerstrat(:,:,:,mth_cur)
     176          pizaerstrat_mois(1,:,:,:) = pizaerstrat(:,:,:,mth_cur)
     177          cgaerstrat_mois(1,:,:,:)  = cgaerstrat(:,:,:,mth_cur)
    166178
    167179!--copy longitudes
    168         DO i=2, n_lon
    169          tauaerstrat_mois(i,:,:,:) = tauaerstrat_mois(1,:,:,:)
    170          pizaerstrat_mois(i,:,:,:) = pizaerstrat_mois(1,:,:,:)
    171          cgaerstrat_mois(i,:,:,:)  = cgaerstrat_mois(1,:,:,:)
    172         ENDDO
     180          DO i=2, n_lon
     181           tauaerstrat_mois(i,:,:,:) = tauaerstrat_mois(1,:,:,:)
     182           pizaerstrat_mois(i,:,:,:) = pizaerstrat_mois(1,:,:,:)
     183           cgaerstrat_mois(i,:,:,:)  = cgaerstrat_mois(1,:,:,:)
     184          ENDDO
    173185
    174186!---reduce to a klon_glo grid
    175         DO band=1, NSW
    176           CALL grid2dTo1d_glo(tauaerstrat_mois(:,:,:,band),tauaerstrat_mois_glo(:,:,band))
    177           CALL grid2dTo1d_glo(pizaerstrat_mois(:,:,:,band),pizaerstrat_mois_glo(:,:,band))
    178           CALL grid2dTo1d_glo(cgaerstrat_mois(:,:,:,band),cgaerstrat_mois_glo(:,:,band))
    179         ENDDO
    180 
     187          DO band=1, NSW
     188            CALL grid2dTo1d_glo(tauaerstrat_mois(:,:,:,band),tauaerstrat_mois_glo(:,:,band))
     189            CALL grid2dTo1d_glo(pizaerstrat_mois(:,:,:,band),pizaerstrat_mois_glo(:,:,band))
     190            CALL grid2dTo1d_glo(cgaerstrat_mois(:,:,:,band),cgaerstrat_mois_glo(:,:,band))
     191          ENDDO
     192        ENDIF
    181193!--Now LW optical properties
    182194!
     195
    183196        CALL nf95_open("taulwstrat.2D.nc", nf90_nowrite, ncid_in)
    184197
    … …  
    194207        CALL nf95_gw_var(ncid_in, varid, latitude)
    195208        n_lat = size(latitude)
    196         IF (n_lat.NE.nbp_lat) THEN
    197            abort_message='Le nombre de lat n est pas egal a nbp_lat'
    198            CALL abort_physic(modname,abort_message,1)
    199         ENDIF
    200 
     209
     210        IF (grid_type/=unstructured) THEN
     211          IF (n_lat.NE.nbp_lat) THEN
     212             abort_message='Le nombre de lat n est pas egal a nbp_lat'
     213             CALL abort_physic(modname,abort_message,1)
     214          ENDIF
     215        ENDIF
     216       
    201217        CALL nf95_inq_varid(ncid_in, "TIME", varid)
    202218        CALL nf95_gw_var(ncid_in, varid, time)
    … …  
    217233
    218234        ALLOCATE(taulwaerstrat(n_lat, n_lev, n_wav, n_month))
    219         ALLOCATE(taulwaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
    220         ALLOCATE(taulwaerstrat_mois_glo(klon_glo, n_lev, n_wav))
    221235
    222236!--reading stratospheric aerosol lw tau per layer
    … …  
    227241        CALL nf95_close(ncid_in)
    228242
     243        IF (grid_type/=unstructured) THEN
     244
     245          ALLOCATE(taulwaerstrat_mois(n_lon, n_lat, n_lev, n_wav))
     246          ALLOCATE(taulwaerstrat_mois_glo(klon_glo, n_lev, n_wav))
     247
    229248!--select the correct month
    230249!--and copy into 1st longitude
    231         taulwaerstrat_mois(1,:,:,:) = taulwaerstrat(:,:,:,mth_cur)
     250          taulwaerstrat_mois(1,:,:,:) = taulwaerstrat(:,:,:,mth_cur)
    232251!--copy longitudes
    233         DO i=2, n_lon
    234           taulwaerstrat_mois(i,:,:,:) = taulwaerstrat_mois(1,:,:,:)
    235         ENDDO
     252          DO i=2, n_lon
     253            taulwaerstrat_mois(i,:,:,:) = taulwaerstrat_mois(1,:,:,:)
     254          ENDDO
    236255
    237256!---reduce to a klon_glo grid
    238         DO band=1, NLW
    239           CALL grid2dTo1d_glo(taulwaerstrat_mois(:,:,:,band),taulwaerstrat_mois_glo(:,:,band))
    240         ENDDO
    241 
     257          DO band=1, NLW
     258            CALL grid2dTo1d_glo(taulwaerstrat_mois(:,:,:,band),taulwaerstrat_mois_glo(:,:,band))
     259          ENDDO
     260        ENDIF
     261     
    242262      ELSE !--proc other than mpi_root and omp_root
    243263           !--dummy allocation needed for debug mode
    … …  
    248268        ALLOCATE(taulwaerstrat_mois_glo(1,1,1))
    249269
     270        ALLOCATE(tauaerstrat(0,0,0,12))
     271        ALLOCATE(pizaerstrat(0,0,0,12))
     272        ALLOCATE(cgaerstrat(0,0,0,12))
     273        ALLOCATE(taulwaerstrat(0,0,0,12))
     274
     275
    250276      ENDIF !--is_mpi_root and is_omp_root
    251277
    … …  
    255281      mth_pre=mth_cur
    256282
     283      IF (grid_type==unstructured) THEN
     284
     285#ifdef CPP_XIOS
     286
     287        IF (is_omp_master) THEN
     288          ALLOCATE(tauaerstrat_mpi(klon_mpi, klev, NSW))
     289          ALLOCATE(pizaerstrat_mpi(klon_mpi, klev, NSW))
     290          ALLOCATE(cgaerstrat_mpi(klon_mpi, klev, NSW))       
     291          ALLOCATE(taulwaerstrat_mpi(klon_mpi, klev, NLW))
     292         
     293          CALL xios_send_field("tauaerstrat_in",SPREAD(tauaerstrat(:,:,:,mth_cur),1,8))
     294          CALL xios_recv_field("tauaerstrat_out",tauaerstrat_mpi)
     295          CALL xios_send_field("pizaerstrat_in",SPREAD(pizaerstrat(:,:,:,mth_cur),1,8))
     296          CALL xios_recv_field("pizaerstrat_out",pizaerstrat_mpi)
     297          CALL xios_send_field("cgaerstrat_in",SPREAD(cgaerstrat(:,:,:,mth_cur),1,8))
     298          CALL xios_recv_field("cgaerstrat_out",cgaerstrat_mpi)
     299          CALL xios_send_field("taulwaerstrat_in",SPREAD(taulwaerstrat(:,:,:,mth_cur),1,8))
     300          CALL xios_recv_field("taulwaerstrat_out",taulwaerstrat_mpi)
     301        ELSE
     302          ALLOCATE(tauaerstrat_mpi(0, 0, 0))
     303          ALLOCATE(pizaerstrat_mpi(0, 0, 0))
     304          ALLOCATE(cgaerstrat_mpi(0, 0, 0))       
     305          ALLOCATE(taulwaerstrat_mpi(0, 0, 0))
     306        ENDIF 
     307       
     308        CALL scatter_omp(tauaerstrat_mpi,tau_aer_strat)
     309        CALL scatter_omp(pizaerstrat_mpi,piz_aer_strat)
     310        CALL scatter_omp(cgaerstrat_mpi,cg_aer_strat)
     311        CALL scatter_omp(taulwaerstrat_mpi,taulw_aer_strat)
     312#endif
     313      ELSE 
     314       
    257315!--scatter on all proc
    258       CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
    259       CALL scatter(pizaerstrat_mois_glo,piz_aer_strat)
    260       CALL scatter(cgaerstrat_mois_glo,cg_aer_strat)
    261       CALL scatter(taulwaerstrat_mois_glo,taulw_aer_strat)
     316        CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
     317        CALL scatter(pizaerstrat_mois_glo,piz_aer_strat)
     318        CALL scatter(cgaerstrat_mois_glo,cg_aer_strat)
     319        CALL scatter(taulwaerstrat_mois_glo,taulw_aer_strat)
     320        IF (is_mpi_root.AND.is_omp_root)  DEALLOCATE(tauaerstrat_mois, pizaerstrat_mois, cgaerstrat_mois, taulwaerstrat_mois)
     321
     322      ENDIF
    262323
    263324      IF (is_mpi_root.AND.is_omp_root) THEN
    264 !
    265         DEALLOCATE(tauaerstrat, pizaerstrat, cgaerstrat)
    266         DEALLOCATE(tauaerstrat_mois, pizaerstrat_mois, cgaerstrat_mois)
    267         DEALLOCATE(taulwaerstrat,taulwaerstrat_mois)
    268 !
    269       ENDIF !--is_mpi_root and is_omp_root
    270 
    271       DEALLOCATE(tauaerstrat_mois_glo,pizaerstrat_mois_glo,cgaerstrat_mois_glo)
    272       DEALLOCATE(taulwaerstrat_mois_glo)
     325        DEALLOCATE(tauaerstrat, pizaerstrat, cgaerstrat,taulwaerstrat)
     326      ENDIF
     327     
    273328
    274329!$OMP BARRIER
    … …  
    290345    ENDDO
    291346
     347    IF (.NOT. ok_volcan) THEN
     348!
     349!--this is the default case
     350!--stratospheric aerosols are added to both index 2 and 1 for double radiation calls
    292351!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
    293352    DO band=1, NSW
    294353      WHERE (stratomask.GT.0.999999)
    295 !--anthropogenic aerosols bands 1 to NSW
     354!--strat aerosols are added to index 2 : natural and anthropogenic aerosols for bands 1 to NSW
    296355        cg_aero_sw_rrtm(:,:,2,band)  = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + &
    297356                                         cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) /              &
    … …  
    302361                                    MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band), 1.e-15 )
    303362        tau_aero_sw_rrtm(:,:,2,band)  = tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band)
    304 !--natural aerosols bands 1 to NSW
     363!--strat aerosols are added to index 1 : natural aerosols only for bands 1 to NSW
    305364        cg_aero_sw_rrtm(:,:,1,band)  = ( cg_aero_sw_rrtm(:,:,1,band)*piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + &
     365                cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) /              &
     366                MAX( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) +                             &
     367                piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 )
     368        piz_aero_sw_rrtm(:,:,1,band) = ( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) +                             &
     369                piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) /                                     &
     370                MAX( tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band), 1.e-15 )
     371        tau_aero_sw_rrtm(:,:,1,band)  = tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band)
     372    ENDWHERE
     373    ENDDO
     374!
     375    ELSE
     376!
     377!--this is the VOLMIP case
     378!--stratospheric aerosols are only added to index 2 in this case
     379!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
     380    DO band=1, NSW
     381      WHERE (stratomask.GT.0.999999)
     382!--strat aerosols are added to index 2 : natural and anthropogenic aerosols for bands 1 to NSW
     383        cg_aero_sw_rrtm(:,:,2,band)  = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + &
    306384                                         cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) /              &
    307                                     MAX( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) +                             &
     385                                    MAX( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) +                             &
    308386                                         piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 )
    309         piz_aero_sw_rrtm(:,:,1,band) = ( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) +                             &
     387        piz_aero_sw_rrtm(:,:,2,band) = ( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) +                             &
    310388                                         piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) /                                     &
    311                                     MAX( tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band), 1.e-15 )
    312         tau_aero_sw_rrtm(:,:,1,band)  = tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band)
    313 !--no stratospheric aerosol in index 1 for these tests
    314 !        cg_aero_sw_rrtm(:,:,1,band)  =  cg_aero_sw_rrtm(:,:,1,band)
    315 !        piz_aero_sw_rrtm(:,:,1,band)  = piz_aero_sw_rrtm(:,:,1,band)
    316 !        tau_aero_sw_rrtm(:,:,1,band)  = tau_aero_sw_rrtm(:,:,1,band)
    317     ENDWHERE
    318     ENDDO
     389                                    MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band), 1.e-15 )
     390        tau_aero_sw_rrtm(:,:,2,band)  = tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band)
     391     ENDWHERE
     392  ENDDO
     393  ENDIF
    319394
    320395!--total vertical aod at 10 um
    … …  
    331406    ENDDO
    332407
     408    IF (.NOT. ok_volcan) THEN
     409!--this is the default case
     410!--stratospheric aerosols are added to both index 2 and 1
    333411    DO band=1, NLW
    334412      WHERE (stratomask.GT.0.999999)
    335413        tau_aero_lw_rrtm(:,:,2,band)  = tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band)
    336414        tau_aero_lw_rrtm(:,:,1,band)  = tau_aero_lw_rrtm(:,:,1,band) + taulw_aer_strat(:,:,band)
    337 !--no stratospheric aerosols in index 1 for these tests
    338 !    tau_aero_lw_rrtm(:,:,1,band)  = tau_aero_lw_rrtm(:,:,1,band)
    339415      ENDWHERE
    340416    ENDDO
     417!
     418    ELSE
     419!
     420!--this is the VOLMIP case
     421    DO band=1, NLW
     422!--stratospheric aerosols are not added to index 1
     423!--and we copy index 2 in index 1 because we want the same dust aerosol LW properties as above
     424      tau_aero_lw_rrtm(:,:,1,band)  = tau_aero_lw_rrtm(:,:,2,band)
     425!
     426      WHERE (stratomask.GT.0.999999)
     427!--stratospheric aerosols are only added to index 2
     428        tau_aero_lw_rrtm(:,:,2,band)  = tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band)
     429      ENDWHERE
     430    ENDDO
     431    ENDIF
    341432
    342433!--default SSA value if there is no aerosol

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/recmwf_aero.F90

    r3412 r3605  
    3030 & PTOPSWAIAERO,PSOLSWAIAERO,&
    3131 & PTOPSWCFAERO,PSOLSWCFAERO,&
     32 & PSWADAERO,& !--NL
    3233!--LW diagnostics CK
    3334 & PTOPLWADAERO,PSOLLWADAERO,&
    3435 & PTOPLWAD0AERO,PSOLLWAD0AERO,&
    3536 & PTOPLWAIAERO,PSOLLWAIAERO,&
     37 & PLWADAERO,& !--NL
    3638!..end
    37  & ok_ade, ok_aie, flag_aerosol,flag_aerosol_strat,flag_aer_feedback)
     39 & ok_ade, ok_aie, ok_volcan, flag_aerosol,flag_aerosol_strat,&
     40 & flag_aer_feedback)
    3841!--fin
    3942
    … …  
    8285! ok_ade---input-L- apply the Aerosol Direct Effect or not?
    8386! ok_aie---input-L- apply the Aerosol Indirect Effect or not?
     87! ok_volcan-input-L- activate volcanic diags (SW heat & LW cool rate, SW & LW flux)
    8488! flag_aerosol-input-I- aerosol flag from 0 to 7
    8589! flag_aerosol_strat-input-I- use stratospheric aerosols flag (T/F)
    … …  
    213217REAL(KIND=JPRB)   ,INTENT(IN)    :: PREF_ICE_PI(KPROMA,KLEV)
    214218LOGICAL, INTENT(in)  :: ok_ade, ok_aie         ! switches whether to use aerosol direct (indirect) effects or not
     219LOGICAL, INTENT(in)  :: ok_volcan              ! produce volcanic diags (SW/LW heat flux and rate)
    215220INTEGER, INTENT(in)  :: flag_aerosol           ! takes value 0 (no aerosol) or 1 to 6 (aerosols)
    216221LOGICAL, INTENT(in)  :: flag_aerosol_strat     ! use stratospheric aerosols
    … …  
    221226REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTOPSWCFAERO(KPROMA,3), PSOLSWCFAERO(KPROMA,3) !--do we keep this ?
    222227!--fin
     228!--NL
     229REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSWADAERO(KPROMA, KLEV+1)                        ! SW Aerosol direct forcing
     230REAL(KIND=JPRB)   ,INTENT(OUT)   :: PLWADAERO(KPROMA, KLEV+1)                        ! LW Aerosol direct forcing
    223231!--CK
    224232REAL(KIND=JPRB)   ,INTENT(out)   :: PTOPLWADAERO(KPROMA), PSOLLWADAERO(KPROMA)       ! LW Aerosol direct forcing at TOA + surface
    … …  
    811819     PSOLSWAD0AERO(:) = (ZFSDN0_AERO(:,1,4)     -ZFSUP0_AERO(:,1,4))     -(ZFSDN0_AERO(:,1,2)     -ZFSUP0_AERO(:,1,2))
    812820     PTOPSWAD0AERO(:) = (ZFSDN0_AERO(:,KLEV+1,4)-ZFSUP0_AERO(:,KLEV+1,4))-(ZFSDN0_AERO(:,KLEV+1,2)-ZFSUP0_AERO(:,KLEV+1,2))
     821     IF(ok_volcan) THEN
     822        PSWADAERO(:,:)  = (ZFSDN_AERO(:,:,4) -ZFSUP_AERO(:,:,4)) -(ZFSDN_AERO(:,:,2) -ZFSUP_AERO(:,:,2)) !--NL
     823     ENDIF
    813824
    814825! indirect anthropogenic forcing
    … …  
    831842     PSOLLWAD0AERO(:) = (-LWDN0_AERO(:,1,4)     -LWUP0_AERO(:,1,4))     -(-LWDN0_AERO(:,1,2)     -LWUP0_AERO(:,1,2))
    832843     PTOPLWAD0AERO(:) = (-LWDN0_AERO(:,KLEV+1,4)-LWUP0_AERO(:,KLEV+1,4))-(-LWDN0_AERO(:,KLEV+1,2)-LWUP0_AERO(:,KLEV+1,2))
     844     IF(ok_volcan) THEN
     845        PLWADAERO(:,:)  = (-LWDN_AERO(:,:,4) -LWUP_AERO(:,:,4)) -(-LWDN_AERO(:,:,2) -LWUP_AERO(:,:,2)) !--NL
     846     ENDIF
    833847
    834848! LW indirect anthropogenic forcing
    … …  
    845859     PSOLSWAD0AERO(:) = (ZFSDN0_AERO(:,1,3)     -ZFSUP0_AERO(:,1,3))     -(ZFSDN0_AERO(:,1,1)     -ZFSUP0_AERO(:,1,1))
    846860     PTOPSWAD0AERO(:) = (ZFSDN0_AERO(:,KLEV+1,3)-ZFSUP0_AERO(:,KLEV+1,3))-(ZFSDN0_AERO(:,KLEV+1,1)-ZFSUP0_AERO(:,KLEV+1,1))
     861     IF(ok_volcan) THEN
     862        PSWADAERO(:,:)  = (ZFSDN_AERO(:,:,3) -ZFSUP_AERO(:,:,3)) -(ZFSDN_AERO(:,:,1) -ZFSUP_AERO(:,:,1)) !--NL
     863     ENDIF
    847864
    848865! indirect anthropogenic forcing
    … …  
    865882     PSOLLWAD0AERO(:) = (-LWDN0_AERO(:,1,3)     -LWUP0_AERO(:,1,3))     -(-LWDN0_AERO(:,1,1)     -LWUP0_AERO(:,1,1))
    866883     PTOPLWAD0AERO(:) = (-LWDN0_AERO(:,KLEV+1,3)-LWUP0_AERO(:,KLEV+1,3))-(-LWDN0_AERO(:,KLEV+1,1)-LWUP0_AERO(:,KLEV+1,1))
    867 
     884     IF(ok_volcan) THEN
     885        PLWADAERO(:,:)  = (-LWDN_AERO(:,:,3) -LWUP_AERO(:,:,3)) -(-LWDN_AERO(:,:,1) -LWUP_AERO(:,:,1)) !--NL
     886     ENDIF
     887     
    868888! LW indirect anthropogenic forcing
    869889     PSOLLWAIAERO(:) = 0.0
    … …  
    879899     PSOLSWAD0AERO(:) = 0.0
    880900     PTOPSWAD0AERO(:) = 0.0
    881 
     901     IF(ok_volcan) THEN
     902        PSWADAERO(:,:)  = 0.0 !--NL
     903     ENDIF
     904     
    882905! indirect anthropogenic forcing
    883906     PSOLSWAIAERO(:) = (ZFSDN_AERO(:,1,2)     -ZFSUP_AERO(:,1,2))     -(ZFSDN_AERO(:,1,1)     -ZFSUP_AERO(:,1,1))
    … …  
    899922     PSOLLWAD0AERO(:) = 0.0
    900923     PTOPLWAD0AERO(:) = 0.0
    901 
     924     IF(ok_volcan) THEN
     925        PLWADAERO(:,:)  = 0.0 !--NL
     926     ENDIF
     927     
    902928! LW indirect anthropogenic forcing
    903929     PSOLLWAIAERO(:) = (-LWDN_AERO(:,1,2)     -LWUP_AERO(:,1,2))     -(-LWDN_AERO(:,1,1)     -LWUP_AERO(:,1,1))
    … …  
    913939     PSOLSWAD0AERO(:) = 0.0
    914940     PTOPSWAD0AERO(:) = 0.0
    915 
     941     IF(ok_volcan) THEN
     942        PSWADAERO(:,:)  = 0.0 !--NL
     943     ENDIF
     944     
    916945! indirect anthropogenic forcing
    917946     PSOLSWAIAERO(:) = 0.0
    … …  
    933962     PSOLLWAD0AERO(:) = 0.0
    934963     PTOPLWAD0AERO(:) = 0.0
    935 
     964     IF(ok_volcan) THEN
     965        PLWADAERO(:,:)  = 0.0 !--NL
     966     ENDIF
     967     
    936968! LW indirect anthropogenic forcing
    937969     PSOLLWAIAERO(:) = 0.0

  • LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/suinit.F90

    r1990 r3605  
    126126ALLOCATE(VDELA  (MAX(JPMXLE,NFLEVG)))
    127127ALLOCATE(VDELB  (MAX(JPMXLE,NFLEVG)))
     128VDELB = 0  !ym missing init
    128129ALLOCATE( VC      (NFLEVG) )
     130VC = 0    !ym missing init
    129131ALLOCATE( NLOEN   (NPROMA) )
    130132ALLOCATE( NLOENG   (NPROMA) )

  • LMDZ6/branches/Ocean_skin/libf/phylmd/simu_airs.F90

    r2585 r3605  
    22        module m_simu_airs
    33
     4        USE print_control_mod, ONLY: prt_level,lunout
     5         
    46        implicit none
    57
    6         real, parameter :: tau_thresh = 0.05 ! seuil nuages detectables
    7         real, parameter :: p_thresh = 445.   ! seuil nuages hauts
    8         real, parameter :: em_min = 0.2      ! seuils nuages semi-transp
    9         real, parameter :: em_max = 0.85
    10         real, parameter :: undef = 999.
     8        REAL, PARAMETER :: tau_thresh = 0.05 ! seuil nuages detectables
     9        REAL, PARAMETER :: p_thresh = 445.   ! seuil nuages hauts
     10        REAL, PARAMETER :: em_min = 0.2      ! seuils nuages semi-transp
     11        REAL, PARAMETER :: em_max = 0.85
     12        REAL, PARAMETER :: undef = 999.
    1113
    1214        contains
    1315
    14         real function search_tropopause(P,T,alt,N) result(P_tropo)
     16        REAL function search_tropopause(P,T,alt,N) result(P_tropo)
    1517! this function searches for the tropopause pressure in [hPa].
    1618! The search is based on ideology described in
    … …  
    1820! GRL, 30(20) 2042, doi:10.1029/2003GL018240, 2003
    1921
    20         integer N,i,i_lev,first_point,exit_flag,i_dir
    21         real P(N),T(N),alt(N),slope(N)
    22         real P_min, P_max, slope_limit,slope_2km, &
     22        INTEGER N,i,i_lev,first_point,exit_flag,i_dir
     23        REAL P(N),T(N),alt(N),slope(N)
     24        REAL P_min, P_max, slope_limit,slope_2km, &
    2325     & delta_alt_limit,tmp,delta_alt
    24         parameter(P_min=75.0, P_max=470.0)   ! hPa
    25         parameter(slope_limit=0.002)         ! 2 K/km converted to K/m
    26         parameter(delta_alt_limit=2000.0)    ! 2000 meters
     26        PARAMETER(P_min=75.0, P_max=470.0)   ! hPa
     27        PARAMETER(slope_limit=0.002)         ! 2 K/km converted to K/m
     28        PARAMETER(delta_alt_limit=2000.0)    ! 2000 meters
    2729
    2830        do i=1,N-1
    … …  
    9395
    9496     
    95         integer :: i, n, nss
    96 
    97         integer, intent(in) :: len_cs
    98         real, dimension(:), intent(in) :: rneb_cs, temp_cs
    99         real, dimension(:), intent(in) :: emis_cs, iwco_cs, rad_cs
    100         real, dimension(:), intent(in) :: pres_cs, dz_cs, rhodz_cs
    101 
    102         real, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, &
     97        INTEGER :: i, n, nss
     98
     99        INTEGER, intent(in) :: len_cs
     100        REAL, DIMENSION(:), intent(in) :: rneb_cs, temp_cs
     101        REAL, DIMENSION(:), intent(in) :: emis_cs, iwco_cs, rad_cs
     102        REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rhodz_cs
     103
     104        REAL, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, &
    103105     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
    104106     & pcld_hc_cs, tcld_hc_cs, em_hc_cs, iwp_hc_cs, &
    … …  
    109111     & deltaz_hc_cs, deltaz_hist_cs, rad_hist_cs
    110112
    111         real, dimension(len_cs) :: rneb_ord
    112         real :: rneb_min
    113 
    114         real, dimension(:), allocatable :: s, s_hc, s_hist, rneb_max
    115         real, dimension(:), allocatable :: sCb, sThCi, sAnv
    116         real, dimension(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,&
     113        REAL, DIMENSION(len_cs) :: rneb_ord
     114        REAL :: rneb_min
     115
     116        REAL, DIMENSION(:), allocatable :: s, s_hc, s_hist, rneb_max
     117        REAL, DIMENSION(:), allocatable :: sCb, sThCi, sAnv
     118        REAL, DIMENSION(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,&
    117119     & emis_ss
    118         real, dimension(:), allocatable :: deltaz_ss, rad_ss
    119 
    120 
    121         write(*,*) 'dans cloud_structure'
     120        REAL, DIMENSION(:), allocatable :: deltaz_ss, rad_ss
     121
     122        CHARACTER (len = 50)      :: modname = 'simu_airs.cloud_structure'
     123        CHARACTER (len = 160)     :: abort_message
     124       
     125
     126        write(lunout,*) 'dans cloud_structure'
    122127
    123128        call ordonne(len_cs, rneb_cs, rneb_ord)
    … …  
    300305        if (cc_tot_cs .gt. maxval(rneb_cs) .and. &
    301306     & abs(cc_tot_cs-maxval(rneb_cs)) .gt. 1.e-4 )  then
    302         write(*,*) 'cc_tot_cs > max rneb_cs'
    303         write(*,*) cc_tot_cs, maxval(rneb_cs)
    304         STOP
     307          WRITE(abort_message,*) 'cc_tot_cs > max rneb_cs', cc_tot_cs, maxval(rneb_cs)
     308          CALL abort_physic(modname,abort_message,1)
    305309        endif
    306310
    307311        if (iwp_hc_cs .lt. 0.) then
    308         write(*,*) 'cloud_structure:'
    309         write(*,*) 'iwp_hc_cs < 0'
    310         STOP
     312          abort_message= 'cloud_structure: iwp_hc_cs < 0'
     313          CALL abort_physic(modname,abort_message,1)
    311314        endif
    312315 
    … …  
    316319        subroutine normal_undef(num, den)
    317320
    318         real, intent(in) :: den
    319         real, intent(inout) :: num
     321        REAL, intent(in) :: den
     322        REAL, intent(inout) :: num
    320323
    321324        if (den .ne. 0) then
    … …  
    330333        subroutine normal2_undef(res,num,den)
    331334
    332         real, intent(in) :: den
    333         real, intent(in) :: num
    334         real, intent(out) :: res
     335        REAL, intent(in) :: den
     336        REAL, intent(in) :: num
     337        REAL, intent(out) :: res
    335338
    336339        if (den .ne. 0.) then
    … …  
    350353     & emis, pcld, tcld, iwp, deltaz, rad)
    351354
    352         integer, intent(in) :: len_cs
    353         real, dimension(len_cs), intent(in) :: rneb_cs, temp_cs
    354         real, dimension(len_cs), intent(in) :: emis_cs, iwco_cs, &
     355        INTEGER, intent(in) :: len_cs
     356        REAL, DIMENSION(len_cs), intent(in) :: rneb_cs, temp_cs
     357        REAL, DIMENSION(len_cs), intent(in) :: emis_cs, iwco_cs, &
    355358     & rneb_ord
    356         real, dimension(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs
    357         real, dimension(len_cs), intent(in) :: rhodz_cs
    358         real, dimension(len_cs) :: tau_cs, w
    359         real, intent(in) :: rnebmax
    360         real, intent(inout) :: stot, shc, shist
    361         real, intent(inout) :: sCb, sThCi, sAnv
    362         real, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad
    363 
    364         integer :: i, ideb, ibeg, iend, nuage, visible
    365         real :: som, som_tau, som_iwc, som_dz, som_rad, tau
     359        REAL, DIMENSION(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs
     360        REAL, DIMENSION(len_cs), intent(in) :: rhodz_cs
     361        REAL, DIMENSION(len_cs) :: tau_cs, w
     362        REAL, intent(in) :: rnebmax
     363        REAL, intent(inout) :: stot, shc, shist
     364        REAL, intent(inout) :: sCb, sThCi, sAnv
     365        REAL, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad
     366
     367        INTEGER :: i, ideb, ibeg, iend, nuage, visible
     368        REAL :: som, som_tau, som_iwc, som_dz, som_rad, tau
     369
     370        CHARACTER (len = 50)      :: modname = 'simu_airs.sous_section'
     371        CHARACTER (len = 160)     :: abort_message
    366372
    367373
    … …  
    491497
    492498        if (iwp .lt. 0.) then
    493         write(*,*) 'ideb iwp =', ideb, iwp
    494         STOP
     499          WRITE(abort_message,*) 'ideb iwp =', ideb, iwp
     500          CALL abort_physic(modname,abort_message,1)
    495501        endif
    496502
    497503        if (deltaz .lt. 0.) then
    498         write(*,*) 'ideb deltaz =', ideb, deltaz
    499         STOP
     504          WRITE(abort_message,*)'ideb deltaz =', ideb, deltaz
     505          CALL abort_physic(modname,abort_message,1)
    500506        endif
    501507
    502508        if (emis .lt. 0.048 .and. emis .ne. 0.) then
    503         write(*,*) 'ideb emis =', ideb, emis
    504         STOP
     509          WRITE(abort_message,*) 'ideb emis =', ideb, emis
     510          CALL abort_physic(modname,abort_message,1)
    505511        endif
    506512
    … …  
    511517     & visible, w)
    512518
    513         integer, intent(in) :: ibeg, iend
    514         real, intent(in) :: som_tau
    515 
    516         integer, intent(inout) :: visible
    517         real, dimension(:), intent(inout) :: w
    518 
    519         integer :: i
     519        INTEGER, intent(in) :: ibeg, iend
     520        REAL, intent(in) :: som_tau
     521
     522        INTEGER, intent(inout) :: visible
     523        REAL, DIMENSION(:), intent(inout) :: w
     524
     525        INTEGER :: i
    520526
    521527
    … …  
    553559     & som_tau, som_iwc, som_dz, som_rad)
    554560
    555         integer, intent(in) :: ibeg, iend
    556         real, dimension(:), intent(in) :: tau_cs, iwco_cs, temp_cs
    557         real, dimension(:), intent(in) :: pres_cs, dz_cs, rad_cs
    558         real, dimension(:), intent(in) :: rhodz_cs
    559         real, intent(out) :: som_tau, som_iwc, som_dz, som_rad
    560         real , intent(out) :: pcld, tcld
    561 
    562         integer :: i, ibase, imid
     561        INTEGER, intent(in) :: ibeg, iend
     562        REAL, DIMENSION(:), intent(in) :: tau_cs, iwco_cs, temp_cs
     563        REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rad_cs
     564        REAL, DIMENSION(:), intent(in) :: rhodz_cs
     565        REAL, intent(out) :: som_tau, som_iwc, som_dz, som_rad
     566        REAL , intent(out) :: pcld, tcld
     567
     568        INTEGER :: i, ibase, imid
     569
     570        CHARACTER (len = 50)      :: modname = 'simu_airs.caract'
     571        CHARACTER (len = 160)     :: abort_message
    563572
    564573! Somme des epaisseurs optiques et des contenus en glace sur le nuage
    … …  
    585594
    586595        if (som_dz .ne. 0.) then
    587         som_rad = som_rad/som_dz
     596          som_rad = som_rad/som_dz
    588597        else
    589         write(*,*) 'som_dez = 0 STOP'
    590         write(*,*) 'ibeg, iend =', ibeg, iend
    591         do i = ibeg, iend
    592         write(*,*) dz_cs(i), rhodz_cs(i)
    593         enddo
    594         STOP
     598          write(*,*) 'som_dez = 0 STOP'
     599          write(*,*) 'ibeg, iend =', ibeg, iend
     600          do i = ibeg, iend
     601             write(*,*) dz_cs(i), rhodz_cs(i)
     602          enddo
     603          abort_message='see above'
     604          CALL abort_physic(modname,abort_message,1)
    595605        endif
    596606
    … …  
    611621        subroutine topbot(ideb,w,ibeg,iend)
    612622
    613         integer, intent(in) :: ideb
    614         real, dimension(:), intent(in) :: w
    615         integer, intent(out) :: ibeg, iend
    616 
    617         integer :: i, itest
     623        INTEGER, intent(in) :: ideb
     624        REAL, DIMENSION(:), intent(in) :: w
     625        INTEGER, intent(out) :: ibeg, iend
     626
     627        INTEGER :: i, itest
    618628
    619629        itest = 0
    … …  
    642652        subroutine ordonne(len_cs, rneb_cs, rneb_ord)
    643653
    644         integer, intent(in) :: len_cs
    645         real, dimension(:), intent(in) :: rneb_cs
    646         real, dimension(:), intent(out) :: rneb_ord
    647 
    648         integer :: i, j, ind_min
    649 
    650         real, dimension(len_cs) :: rneb
    651         real :: rneb_max
     654        INTEGER, intent(in) :: len_cs
     655        REAL, DIMENSION(:), intent(in) :: rneb_cs
     656        REAL, DIMENSION(:), intent(out) :: rneb_ord
     657
     658        INTEGER :: i, j, ind_min
     659
     660        REAL, DIMENSION(len_cs) :: rneb
     661        REAL :: rneb_max
    652662
    653663
    … …  
    689699       USE dimphy
    690700
    691        real, dimension(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, &
     701       REAL, DIMENSION(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, &
    692702     & iwcon_1D, rad_1D
    693         real, dimension(klev), intent(in) :: pres, dz, rhodz_1D
    694         real, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
    695         real, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
    696         real, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, &
     703        REAL, DIMENSION(klev), intent(in) :: pres, dz, rhodz_1D
     704        REAL, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
     705        REAL, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
     706        REAL, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, &
    697707     & iwp_hc_mesh
    698708
    699         real, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
    700         real, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, &
     709        REAL, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
     710        REAL, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, &
    701711     & em_ThCi_mesh
    702         real, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
    703 
    704         real, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh
    705         real, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh
    706 
    707         real, dimension(:), allocatable :: rneb_cs, temp_cs, emis_cs, &
     712        REAL, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
     713
     714        REAL, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh
     715        REAL, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh
     716
     717        REAL, DIMENSION(:), allocatable :: rneb_cs, temp_cs, emis_cs, &
    708718     & iwco_cs
    709         real, dimension(:), allocatable :: pres_cs, dz_cs, rad_cs, &
     719        REAL, DIMENSION(:), allocatable :: pres_cs, dz_cs, rad_cs, &
    710720     & rhodz_cs
    711721
    712         integer :: i,j,l
    713         integer :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics
    714 
    715         real :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,&
     722        INTEGER :: i,j,l
     723        INTEGER :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics
     724
     725        REAL :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,&
    716726     & som_hist
    717         real :: som_emi_hist, som_iwp_hist, som_deltaz_hc, &
     727        REAL :: som_emi_hist, som_iwp_hist, som_deltaz_hc, &
    718728     & som_deltaz_hist
    719         real :: som_rad_hist
    720         real :: som_Cb, som_ThCi, som_Anv
    721         real :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb
    722         real :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv
    723         real :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi
    724         real :: tsom_tot, tsom_hc, tsom_hist
    725         real :: prod, prod_hh
    726 
    727         real :: cc_tot_cs, cc_hc_cs, cc_hist_cs
    728         real :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs
    729         real :: pcld_hc_cs, tcld_hc_cs
    730         real :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs
    731         real :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs
    732         real :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs
    733         real :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs
    734         real :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs
    735 
    736         real, dimension(klev) :: test_tot, test_hc, test_hist
    737         real, dimension(klev) :: test_pcld, test_tcld, test_em, test_iwp
    738 
     729        REAL :: som_rad_hist
     730        REAL :: som_Cb, som_ThCi, som_Anv
     731        REAL :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb
     732        REAL :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv
     733        REAL :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi
     734        REAL :: tsom_tot, tsom_hc, tsom_hist
     735        REAL :: prod, prod_hh
     736
     737        REAL :: cc_tot_cs, cc_hc_cs, cc_hist_cs
     738        REAL :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs
     739        REAL :: pcld_hc_cs, tcld_hc_cs
     740        REAL :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs
     741        REAL :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs
     742        REAL :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs
     743        REAL :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs
     744        REAL :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs
     745
     746        REAL, DIMENSION(klev) :: test_tot, test_hc, test_hist
     747        REAL, DIMENSION(klev) :: test_pcld, test_tcld, test_em, test_iwp
     748
     749        CHARACTER (len = 50)      :: modname = 'simu_airs.sim_mesh'
     750        CHARACTER (len = 160)     :: abort_message
     751       
    739752
    740753        do j = 1, klev
    741         write(*,*) 'simu_airs, j, rneb_1D =', rneb_1D(j)
     754          WRITE(lunout,*) 'simu_airs, j, rneb_1D =', rneb_1D(j)
    742755        enddo
    743756
    … …  
    9911004       if (cc_tot_mesh .gt. tsom_tot .and. &
    9921005     & abs(cc_tot_mesh-tsom_tot) .gt. 1.e-4) then
    993         write(*,*) 'cc_tot_mesh > tsom_tot'
    994         write(*,*) cc_tot_mesh, tsom_tot
    995         STOP
     1006           WRITE(abort_message,*)'cc_tot_mesh > tsom_tot', cc_tot_mesh, tsom_tot
     1007           CALL abort_physic(modname,abort_message,1)
    9961008        endif
    9971009
    9981010        if (cc_tot_mesh .lt. maxval(test_tot(1:N_CS)) .and. &
    9991011     & abs(cc_tot_mesh-maxval(test_tot(1:N_CS))) .gt. 1.e-4) then
    1000         write(*,*) 'cc_tot_mesh < max'
    1001         write(*,*) cc_tot_mesh, maxval(test_tot(1:N_CS))
    1002         STOP
     1012           WRITE(abort_message,*) 'cc_tot_mesh < max', cc_tot_mesh, maxval(test_tot(1:N_CS))
     1013           CALL abort_physic(modname,abort_message,1)
    10031014        endif
    10041015
    10051016        if (cc_hc_mesh .gt. tsom_hc .and. &
    10061017     & abs(cc_hc_mesh-tsom_hc) .gt. 1.e-4) then
    1007         write(*,*) 'cc_hc_mesh > tsom_hc'
    1008         write(*,*) cc_hc_mesh, tsom_hc
    1009         STOP
     1018           WRITE(abort_message,*) 'cc_hc_mesh > tsom_hc', cc_hc_mesh, tsom_hc
     1019           CALL abort_physic(modname,abort_message,1)
    10101020        endif
    10111021
    10121022        if (cc_hc_mesh .lt. maxval(test_hc(1:N_CS)) .and. &
    10131023     & abs(cc_hc_mesh-maxval(test_hc(1:N_CS))) .gt. 1.e-4) then
    1014         write(*,*) 'cc_hc_mesh < max'
    1015         write(*,*) cc_hc_mesh, maxval(test_hc(1:N_CS))
    1016         STOP
     1024           WRITE(abort_message,*) 'cc_hc_mesh < max', cc_hc_mesh, maxval(test_hc(1:N_CS))
     1025           CALL abort_physic(modname,abort_message,1)
    10171026        endif
    10181027
    10191028        if (cc_hist_mesh .gt. tsom_hist .and. &
    10201029     & abs(cc_hist_mesh-tsom_hist) .gt. 1.e-4) then
    1021         write(*,*) 'cc_hist_mesh > tsom_hist'
    1022         write(*,*) cc_hist_mesh, tsom_hist
    1023         STOP
     1030           WRITE(abort_message,*) 'cc_hist_mesh > tsom_hist', cc_hist_mesh, tsom_hist
     1031           CALL abort_physic(modname,abort_message,1)
    10241032        endif
    10251033
    10261034        if (cc_hist_mesh .lt. 0.) then
    1027         write(*,*) 'cc_hist_mesh < 0'
    1028         write(*,*) cc_hist_mesh
    1029         STOP
     1035           WRITE(abort_message,*) 'cc_hist_mesh < 0', cc_hist_mesh
     1036           CALL abort_physic(modname,abort_message,1)
    10301037        endif
    10311038
    … …  
    10351042     & maxval(test_pcld(1:N_CS)) .ne. 999. &
    10361043     & .and. minval(test_pcld(1:N_CS)) .ne. 999.) then
    1037         write(*,*) 'pcld_hc_mesh est faux'
    1038         write(*,*) pcld_hc_mesh, maxval(test_pcld(1:N_CS)), &
     1044           WRITE(abort_message,*) 'pcld_hc_mesh est faux', pcld_hc_mesh, maxval(test_pcld(1:N_CS)), &
    10391045     & minval(test_pcld(1:N_CS))
    1040         STOP
     1046           CALL abort_physic(modname,abort_message,1)
    10411047        endif
    10421048
    … …  
    10461052     & maxval(test_tcld(1:N_CS)) .ne. 999. &
    10471053     & .and. minval(test_tcld(1:N_CS)) .ne. 999.) then
    1048         write(*,*) 'tcld_hc_mesh est faux'
    1049         write(*,*) tcld_hc_mesh, maxval(test_tcld(1:N_CS)), &
    1050      & minval(test_tcld(1:N_CS))
     1054           WRITE(abort_message,*) 'tcld_hc_mesh est faux', tcld_hc_mesh, maxval(test_tcld(1:N_CS)), &
     1055                & minval(test_tcld(1:N_CS))
     1056           CALL abort_physic(modname,abort_message,1)
    10511057        endif
    10521058
    … …  
    10561062     & minval(test_em(1:N_CS)) .ne. 999. .and. &
    10571063     & maxval(test_em(1:N_CS)) .ne. 999. ) then
    1058         write(*,*) 'em_hc_mesh est faux'
    1059         write(*,*) em_hc_mesh, maxval(test_em(1:N_CS)), &
     1064           WRITE(abort_message,*) 'em_hc_mesh est faux', em_hc_mesh, maxval(test_em(1:N_CS)), &
    10601065     & minval(test_em(1:N_CS))
    1061         STOP
     1066           CALL abort_physic(modname,abort_message,1)
    10621067        endif
    10631068
    … …  
    11011106        subroutine test_bornes(sx,x,bsup,binf)
    11021107
    1103         real, intent(in) :: x, bsup, binf
     1108        REAL, intent(in) :: x, bsup, binf
    11041109        character*14, intent(in) :: sx
     1110        CHARACTER (len = 50)      :: modname = 'simu_airs.test_bornes'
     1111        CHARACTER (len = 160)     :: abort_message
    11051112
    11061113        if (x .gt. bsup .or. x .lt. binf) then
    1107         write(*,*) sx, 'est faux'
    1108         write(*,*) sx, x
    1109         STOP
     1114          WRITE(abort_message,*) sx, 'est faux', sx, x
     1115          CALL abort_physic(modname,abort_message,1)
    11101116        endif
    11111117 
    … …  
    11341140        include "YOMCST.h"
    11351141
    1136         integer,intent(in) :: itap
    1137 
    1138         real, dimension(klon,klev), intent(in) :: &
     1142        INTEGER,intent(in) :: itap
     1143
     1144        REAL, DIMENSION(klon,klev), intent(in) :: &
    11391145     & rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, &
    11401146     & rad_airs, geop_airs, pplay_airs, paprs_airs
    11411147
    1142        real, dimension(klon,klev) :: &
     1148       REAL, DIMENSION(klon,klev) :: &
    11431149     & rhodz_airs, rho_airs, iwcon_airs
    11441150
    1145         real, dimension(klon),intent(out) :: alt_tropo
    1146 
    1147         real, dimension(klev) :: rneb_1D, temp_1D, &
     1151        REAL, DIMENSION(klon),intent(out) :: alt_tropo
     1152
     1153        REAL, DIMENSION(klev) :: rneb_1D, temp_1D, &
    11481154     & emis_1D, rad_1D, pres_1D, alt_1D, &
    11491155     & rhodz_1D, dz_1D, iwcon_1D
    11501156
    1151         integer :: i, j
    1152 
    1153         real :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
    1154         real :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
    1155         real :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh
    1156         real :: em_hist_mesh, iwp_hist_mesh
    1157         real :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh
    1158         real :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
    1159         real :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh
    1160         real :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
    1161 
    1162         real, dimension(klon),intent(out) :: map_prop_hc, map_prop_hist
    1163         real, dimension(klon),intent(out) :: map_emis_hc, map_iwp_hc
    1164         real, dimension(klon),intent(out) :: map_deltaz_hc, map_pcld_hc
    1165         real, dimension(klon),intent(out) :: map_tcld_hc
    1166         real, dimension(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb
    1167         real, dimension(klon),intent(out) :: &
     1157        INTEGER :: i, j
     1158
     1159        REAL :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
     1160        REAL :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
     1161        REAL :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh
     1162        REAL :: em_hist_mesh, iwp_hist_mesh
     1163        REAL :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh
     1164        REAL :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
     1165        REAL :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh
     1166        REAL :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
     1167
     1168        REAL, DIMENSION(klon),intent(out) :: map_prop_hc, map_prop_hist
     1169        REAL, DIMENSION(klon),intent(out) :: map_emis_hc, map_iwp_hc
     1170        REAL, DIMENSION(klon),intent(out) :: map_deltaz_hc, map_pcld_hc
     1171        REAL, DIMENSION(klon),intent(out) :: map_tcld_hc
     1172        REAL, DIMENSION(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb
     1173        REAL, DIMENSION(klon),intent(out) :: &
    11681174     & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi
    1169         real, dimension(klon),intent(out) :: &
     1175        REAL, DIMENSION(klon),intent(out) :: &
    11701176     & map_emis_Anv,map_pcld_Anv,map_tcld_Anv
    1171         real, dimension(klon),intent(out) :: &
     1177        REAL, DIMENSION(klon),intent(out) :: &
    11721178     & map_emis_hist,map_iwp_hist,map_deltaz_hist,&
    11731179     & map_rad_hist
    1174        real, dimension(klon),intent(out) :: map_ntot,map_hc,map_hist
    1175        real, dimension(klon),intent(out) :: map_Cb,map_ThCi,map_Anv
     1180        REAL, DIMENSION(klon),intent(out) :: map_ntot,map_hc,map_hist
     1181        REAL, DIMENSION(klon),intent(out) :: map_Cb,map_ThCi,map_Anv
    11761182 
    11771183 

  • LMDZ6/branches/Ocean_skin/libf/phylmd/sisvat/surf_sisvat_mod.F90

    r2345 r3605  
    15401540    INTEGER isl, ikl, i, isn
    15411541    CHARACTER (len=2) :: str2
     1542    INTEGER           :: pass
    15421543
    15431544      isno(:)       = 0       
    … …  
    16171618
    16181619      CALL open_restartphy(fichnom)
    1619       CALL put_field("longitude", &
     1620      DO pass = 1, 2
     1621        CALL put_field(pass,"longitude", &
    16201622                    "Longitudes de la grille physique",rlon)     
    1621       CALL put_field("latitude","Latitudes de la grille physique",rlat)
    1622 
    1623       CALL put_field("n_snows", "number of snow/ice layers",isno)
    1624       CALL put_field("n_ice_top", "number of top ice layers",ispi)
    1625       CALL put_field("n_ice", "number of ice layers",iice)
    1626       CALL put_field("IR_soil", "Soil IR flux",IRs)
    1627       CALL put_field("LMO", "Monin-Obukhov Scale",LMO)
    1628       CALL put_field("surf_water", "Surficial water",rusn)
    1629       CALL put_field("snow_buffer", "Snow buffer layer",Bufs)
    1630       CALL put_field("alb_1", "albedo sw",alb1)
    1631       CALL put_field("alb_2", "albedo nIR",alb2)
    1632       CALL put_field("alb_3", "albedo fIR",alb3)
    1633       CALL put_field("to_ice", "Snow passed to ice",toic)
     1623        CALL put_field(pass,"latitude","Latitudes de la grille physique",rlat)
     1624 
     1625        CALL put_field(pass,"n_snows", "number of snow/ice layers",isno)
     1626        CALL put_field(pass,"n_ice_top", "number of top ice layers",ispi)
     1627        CALL put_field(pass,"n_ice", "number of ice layers",iice)
     1628        CALL put_field(pass,"IR_soil", "Soil IR flux",IRs)
     1629        CALL put_field(pass,"LMO", "Monin-Obukhov Scale",LMO)
     1630        CALL put_field(pass,"surf_water", "Surficial water",rusn)
     1631        CALL put_field(pass,"snow_buffer", "Snow buffer layer",Bufs)
     1632        CALL put_field(pass,"alb_1", "albedo sw",alb1)
     1633        CALL put_field(pass,"alb_2", "albedo nIR",alb2)
     1634        CALL put_field(pass,"alb_3", "albedo fIR",alb3)
     1635        CALL put_field(pass,"to_ice", "Snow passed to ice",toic)
    16341636
    16351637 !     DO i = 1, 5
    16361638 !       WRITE(str2,'(i2.2)') i
    1637  !       CALL put_field("turb_veloc"//str2, &
     1639 !       CALL put_field(pass,"turb_veloc"//str2, &
    16381640 !                      "various turbulent velocities"//str2, &
    16391641 !                      turb_vel(:,i))
    … …  
    16411643 !     DO i = 1, 9
    16421644 !       WRITE(str2,'(i2.2)') i
    1643  !       CALL put_field("rough_length"//str2, &
     1645 !       CALL put_field(pass,"rough_length"//str2, &
    16441646 !                      "various roughness lengths"//str2, &
    16451647 !                      rlength(:,i))
    16461648 !     ENDDO
    1647       DO isn = 1,nsno
    1648         IF (isn.LE.99) THEN
    1649           WRITE(str2,'(i2.2)') isn
    1650           CALL put_field("AGESNOW"//str2, &
     1649        DO isn = 1,nsno
     1650          IF (isn.LE.99) THEN
     1651            WRITE(str2,'(i2.2)') isn
     1652            CALL put_field(pass,"AGESNOW"//str2, &
    16511653                         "Age de la neige layer No."//str2, &
    16521654                         agsn(:,isn))
    1653         ELSE
    1654           PRINT*, "Trop de couches"
    1655           CALL abort
    1656         ENDIF
    1657       ENDDO
    1658       DO isn = 1,nsno
    1659         IF (isn.LE.99) THEN
    1660           WRITE(str2,'(i2.2)') isn
    1661           CALL put_field("DZSNOW"//str2, &
     1655          ELSE
     1656            PRINT*, "Trop de couches"
     1657            CALL abort
     1658          ENDIF
     1659        ENDDO
     1660        DO isn = 1,nsno
     1661          IF (isn.LE.99) THEN
     1662            WRITE(str2,'(i2.2)') isn
     1663            CALL put_field(pass,"DZSNOW"//str2, &
    16621664                         "Snow/ice thickness layer No."//str2, &
    16631665                         dzsn(:,isn))
    1664         ELSE
    1665           PRINT*, "Trop de couches"
    1666           CALL abort
    1667         ENDIF
    1668       ENDDO
    1669       DO isn = 1,nsno
    1670         IF (isn.LE.99) THEN
    1671           WRITE(str2,'(i2.2)') isn
    1672           CALL put_field("G2SNOW"//str2, &
     1666          ELSE
     1667            PRINT*, "Trop de couches"
     1668            CALL abort
     1669          ENDIF
     1670        ENDDO
     1671        DO isn = 1,nsno
     1672          IF (isn.LE.99) THEN
     1673            WRITE(str2,'(i2.2)') isn
     1674            CALL put_field(pass,"G2SNOW"//str2, &
    16731675                         "Snow Property 2, layer No."//str2, &
    16741676                         G2sn(:,isn))
    1675         ELSE
    1676           PRINT*, "Trop de couches"
    1677           CALL abort
    1678         ENDIF
    1679       ENDDO
    1680       DO isn = 1,nsno
    1681         IF (isn.LE.99) THEN
    1682           WRITE(str2,'(i2.2)') isn
    1683           CALL put_field("G1SNOW"//str2, &
     1677          ELSE
     1678            PRINT*, "Trop de couches"
     1679            CALL abort
     1680          ENDIF
     1681        ENDDO
     1682        DO isn = 1,nsno
     1683          IF (isn.LE.99) THEN
     1684            WRITE(str2,'(i2.2)') isn
     1685            CALL put_field(pass,"G1SNOW"//str2, &
    16841686                         "Snow Property 1, layer No."//str2, &
    16851687                         G1sn(:,isn))
    1686         ELSE
    1687           PRINT*, "Trop de couches"
    1688           CALL abort
    1689         ENDIF
    1690       ENDDO
    1691       DO isn = 1,nsismx
    1692         IF (isn.LE.99) THEN
    1693           WRITE(str2,'(i2.2)') isn
    1694           CALL put_field("ETA"//str2, &
     1688          ELSE
     1689            PRINT*, "Trop de couches"
     1690            CALL abort
     1691          ENDIF
     1692        ENDDO
     1693        DO isn = 1,nsismx
     1694          IF (isn.LE.99) THEN
     1695            WRITE(str2,'(i2.2)') isn
     1696            CALL put_field(pass,"ETA"//str2, &
    16951697                         "Soil/snow water content layer No."//str2, &
    16961698                         eta(:,isn))
    1697         ELSE
    1698           PRINT*, "Trop de couches"
    1699           CALL abort
    1700         ENDIF
     1699          ELSE
     1700            PRINT*, "Trop de couches"
     1701            CALL abort
     1702          ENDIF
     1703        ENDDO
     1704        DO isn = 1,nsismx   !nsno
     1705          IF (isn.LE.99) THEN
     1706            WRITE(str2,'(i2.2)') isn
     1707            CALL put_field(pass,"RO"//str2, &
     1708                           "Snow density layer No."//str2, &
     1709                           ro(:,isn))
     1710          ELSE
     1711            PRINT*, "Trop de couches"
     1712            CALL abort
     1713          ENDIF
     1714        ENDDO
     1715        DO isn = 1,nsismx
     1716          IF (isn.LE.99) THEN
     1717            WRITE(str2,'(i2.2)') isn
     1718            CALL put_field(pass,"TSS"//str2, &
     1719                           "Soil/snow temperature layer No."//str2, &
     1720                           Tsis(:,isn))
     1721          ELSE
     1722            PRINT*, "Trop de couches"
     1723            CALL abort
     1724          ENDIF
     1725        ENDDO
     1726        DO isn = 1,nsno
     1727          IF (isn.LE.99) THEN
     1728            WRITE(str2,'(i2.2)') isn
     1729            CALL put_field(pass,"HISTORY"//str2, &
     1730                           "Snow history layer No."//str2, &
     1731                           isto(:,isn))
     1732          ELSE
     1733            PRINT*, "Trop de couches"
     1734            CALL abort
     1735          ENDIF
     1736        ENDDO
    17011737      ENDDO
    1702       DO isn = 1,nsismx   !nsno
    1703         IF (isn.LE.99) THEN
    1704           WRITE(str2,'(i2.2)') isn
    1705           CALL put_field("RO"//str2, &
    1706                          "Snow density layer No."//str2, &
    1707                          ro(:,isn))
    1708         ELSE
    1709           PRINT*, "Trop de couches"
    1710           CALL abort
    1711         ENDIF
    1712       ENDDO
    1713       DO isn = 1,nsismx
    1714         IF (isn.LE.99) THEN
    1715           WRITE(str2,'(i2.2)') isn
    1716           CALL put_field("TSS"//str2, &
    1717                          "Soil/snow temperature layer No."//str2, &
    1718                          Tsis(:,isn))
    1719         ELSE
    1720           PRINT*, "Trop de couches"
    1721           CALL abort
    1722         ENDIF
    1723       ENDDO
    1724       DO isn = 1,nsno
    1725         IF (isn.LE.99) THEN
    1726           WRITE(str2,'(i2.2)') isn
    1727           CALL put_field("HISTORY"//str2, &
    1728                          "Snow history layer No."//str2, &
    1729                          isto(:,isn))
    1730         ELSE
    1731           PRINT*, "Trop de couches"
    1732           CALL abort
    1733         ENDIF
    1734       ENDDO
    17351738
    17361739  END SUBROUTINE sisvatredem

  • LMDZ6/branches/Ocean_skin/libf/phylmd/slab_heat_transp_mod.F90

    r3002 r3605  
    8383                                  cu_,cuvsurcv_,cv_,cvusurcu_, &
    8484                                  aire_,apoln_,apols_, &
    85                                   aireu_,airev_,rlatv)
    86     USE comconst_mod, ONLY: omeg, rad
     85                                  aireu_,airev_,rlatv, rad, omeg)
    8786    ! number of points in lon, lat
    8887    IMPLICIT NONE
    … …  
    104103    REAL,INTENT(IN) :: airev_(ip1jm)
    105104    REAL,INTENT(IN) :: rlatv(nbp_lat-1)
    106 
     105    REAL,INTENT(IN) :: rad
     106    REAL,INTENT(IN) :: omeg
     107
     108    CHARACTER (len = 20) :: modname = 'slab_heat_transp'
     109    CHARACTER (len = 80) :: abort_message
     110   
    107111    ! Sanity check on dimensions
    108112    if ((ip1jm.ne.((nbp_lon+1)*(nbp_lat-1))).or. &
    109113        (ip1jmp1.ne.((nbp_lon+1)*nbp_lat))) then
    110       write(*,*) "ini_slab_transp_geom Error: wrong array sizes"
    111       stop
     114      abort_message="ini_slab_transp_geom Error: wrong array sizes"
     115      CALL abort_physic(modname,abort_message,1)
    112116    endif
    113117! Allocations could be done only on master process/thread...
    … …  
    924928  INTEGER j,ifield,ig
    925929
     930  CHARACTER (len = 20)                      :: modname = 'slab_heat_transp'
     931  CHARACTER (len = 80)                      :: abort_message
     932
    926933  ! Sanity check:
    927934  IF(klon_glo.NE.2+(jm-2)*(im-1)) THEN
    928     WRITE(*,*) "gr_dyn_fi error, wrong sizes"
    929     STOP
     935    abort_message="gr_dyn_fi error, wrong sizes"
     936    CALL abort_physic(modname,abort_message,1)
    930937  ENDIF
    931938

  • LMDZ6/branches/Ocean_skin/libf/phylmd/suphel.F90

    r3429 r3605  
    118118  rmo3 = 47.9942
    119119  rmco2 = 44.011
     120  rmch4 = 16.043
     121  rmn2o = 44.013
     122  rmcfc11 = 137.3686
     123  rmcfc12 = 120.9140
    120124  rmc   = 12.0107
    121125  rmv = 18.0153
    … …  
    134138  WRITE (UNIT=6, FMT='('' Ozone   mass = '',e13.7)') rmo3
    135139  WRITE (UNIT=6, FMT='('' CO2     mass = '',e13.7)') rmco2
    136   WRITE (UNIT=6, FMT='('' CO2     mass = '',e13.7)') rmc
     140  WRITE (UNIT=6, FMT='('' C       mass = '',e13.7)') rmc
     141  WRITE (UNIT=6, FMT='('' CH4     mass = '',e13.7)') rmch4
     142  WRITE (UNIT=6, FMT='('' N2O     mass = '',e13.7)') rmn2o
     143  WRITE (UNIT=6, FMT='('' CFC11   mass = '',e13.7)') rmcfc11
     144  WRITE (UNIT=6, FMT='('' CFC12   mass = '',e13.7)') rmcfc12
    137145  WRITE (UNIT=6, FMT='('' Vapour  mass = '',e13.7)') rmv
    138146  WRITE (UNIT=6, FMT='('' Dry air cst. = '',e13.7)') rd

  • LMDZ6/branches/Ocean_skin/libf/phylmd/surf_land_mod.F90

    r3391 r3605  
    4141    USE surf_land_orchidee_nofrein_mod
    4242#else
     43#if ORCHIDEE_NOUNSTRUCT
     44    ! Compilation with cpp key ORCHIDEE_NOUNSTRUCT
     45    USE surf_land_orchidee_nounstruct_mod
     46#else
    4347    USE surf_land_orchidee_mod
     48#endif
    4449#endif
    4550#endif

  • LMDZ6/branches/Ocean_skin/libf/phylmd/surf_land_orchidee_mod.F90

    r3391 r3605  
    44#ifndef ORCHIDEE_NOZ0H
    55#ifndef ORCHIDEE_NOFREIN
     6#ifndef ORCHIDEE_NOUNSTRUCT
    67!
    78! This module controles the interface towards the model ORCHIDEE.
    … …  
    2324  USE cpl_mod,      ONLY : cpl_send_land_fields
    2425  USE surface_data, ONLY : type_ocean
    25   USE geometry_mod, ONLY : dx, dy
     26  USE geometry_mod, ONLY : dx, dy, boundslon, boundslat,longitude, latitude, cell_area,  ind_cell_glo
    2627  USE mod_grid_phy_lmdz
    2728  USE mod_phys_lmdz_para, mpi_root_rank=>mpi_master
    2829  USE carbon_cycle_mod, ONLY : nbcf_in_orc, nbcf_out, fields_in, yfields_in, yfields_out, cfname_in, cfname_out
    29 
     30  USE nrtype, ONLY : PI
     31 
    3032  IMPLICIT NONE
    3133
    … …  
    165167    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
    166168    !$OMP THREADPRIVATE(lalo)
     169! boundaries of cells
     170    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE   :: bounds_lalo
     171    !$OMP THREADPRIVATE(bounds_lalo)
    167172! pts voisins
    168173    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
    … …  
    178183    !$OMP THREADPRIVATE(lon_scat,lat_scat)
    179184
     185! area of cells
     186    REAL, ALLOCATABLE, DIMENSION (:), SAVE  :: area 
     187    !$OMP THREADPRIVATE(area)
     188
    180189    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
    181190    !$OMP THREADPRIVATE(lrestart_read)
    … …  
    209218    !$OMP THREADPRIVATE(riverflow)
    210219   
     220    INTEGER :: orch_mpi_rank
     221    INTEGER :: orch_mpi_size
    211222    INTEGER :: orch_omp_rank
    212223    INTEGER :: orch_omp_size
     224
     225    REAL, ALLOCATABLE, DIMENSION(:)         :: longitude_glo
     226    REAL, ALLOCATABLE, DIMENSION(:)         :: latitude_glo
     227    REAL, ALLOCATABLE, DIMENSION(:,:)       :: boundslon_glo
     228    REAL, ALLOCATABLE, DIMENSION(:,:)       :: boundslat_glo
     229    INTEGER, ALLOCATABLE, DIMENSION(:)      :: ind_cell_glo_glo
     230    INTEGER, ALLOCATABLE, SAVE,DIMENSION(:) :: ind_cell
     231    !$OMP THREADPRIVATE(ind_cell)
     232    INTEGER :: begin, end
    213233!
    214234! Fin definition
    … …  
    253273       jg(klon) = nbp_lat
    254274
    255        IF ((.NOT. ALLOCATED(lalo))) THEN
    256           ALLOCATE(lalo(knon,2), stat = error)
     275       IF ((.NOT. ALLOCATED(area))) THEN
     276          ALLOCATE(area(knon), stat = error)
    257277          IF (error /= 0) THEN
     278             abort_message='Pb allocation area'
     279             CALL abort_physic(modname,abort_message,1)
     280          ENDIF
     281       ENDIF
     282       DO igrid = 1, knon
     283          area(igrid) = cell_area(knindex(igrid))
     284       ENDDO
     285       
     286       IF (grid_type==unstructured) THEN
     287
     288
     289         IF ((.NOT. ALLOCATED(lon_scat))) THEN
     290            ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error)
     291            IF (error /= 0) THEN
     292               abort_message='Pb allocation lon_scat'
     293               CALL abort_physic(modname,abort_message,1)
     294            ENDIF
     295         ENDIF
     296 
     297         IF ((.NOT. ALLOCATED(lat_scat))) THEN
     298            ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error)
     299            IF (error /= 0) THEN
     300               abort_message='Pb allocation lat_scat'
     301               CALL abort_physic(modname,abort_message,1)
     302            ENDIF
     303         ENDIF
     304         CALL Gather(rlon,rlon_g)
     305         CALL Gather(rlat,rlat_g)
     306
     307         IF (is_mpi_root) THEN
     308            index = 1
     309            DO jj = 2, nbp_lat-1
     310               DO ij = 1, nbp_lon
     311                  index = index + 1
     312                  lon_scat(ij,jj) = rlon_g(index)
     313                  lat_scat(ij,jj) = rlat_g(index)
     314               ENDDO
     315            ENDDO
     316            lon_scat(:,1) = lon_scat(:,2)
     317            lat_scat(:,1) = rlat_g(1)
     318            lon_scat(:,nbp_lat) = lon_scat(:,2)
     319            lat_scat(:,nbp_lat) = rlat_g(klon_glo)
     320         ENDIF
     321     
     322         CALL bcast(lon_scat)
     323         CALL bcast(lat_scat)
     324               
     325       ELSE IF (grid_type==regular_lonlat) THEN
     326
     327         IF ((.NOT. ALLOCATED(lalo))) THEN
     328            ALLOCATE(lalo(knon,2), stat = error)
     329            IF (error /= 0) THEN
     330               abort_message='Pb allocation lalo'
     331               CALL abort_physic(modname,abort_message,1)
     332            ENDIF
     333         ENDIF
     334       
     335         IF ((.NOT. ALLOCATED(bounds_lalo))) THEN
     336           ALLOCATE(bounds_lalo(knon,nvertex,2), stat = error)
     337           IF (error /= 0) THEN
    258338             abort_message='Pb allocation lalo'
    259339             CALL abort_physic(modname,abort_message,1)
    260           ENDIF
    261        ENDIF
    262        IF ((.NOT. ALLOCATED(lon_scat))) THEN
    263           ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error)
    264           IF (error /= 0) THEN
    265              abort_message='Pb allocation lon_scat'
    266              CALL abort_physic(modname,abort_message,1)
    267           ENDIF
    268        ENDIF
    269        IF ((.NOT. ALLOCATED(lat_scat))) THEN
    270           ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error)
    271           IF (error /= 0) THEN
    272              abort_message='Pb allocation lat_scat'
    273              CALL abort_physic(modname,abort_message,1)
    274           ENDIF
    275        ENDIF
    276        lon_scat = 0.
    277        lat_scat = 0.
    278        DO igrid = 1, knon
    279           index = knindex(igrid)
    280           lalo(igrid,2) = rlon(index)
    281           lalo(igrid,1) = rlat(index)
    282        ENDDO
    283 
    284        
    285        
    286        CALL Gather(rlon,rlon_g)
    287        CALL Gather(rlat,rlat_g)
    288 
    289        IF (is_mpi_root) THEN
    290           index = 1
    291           DO jj = 2, nbp_lat-1
    292              DO ij = 1, nbp_lon
    293                 index = index + 1
    294                 lon_scat(ij,jj) = rlon_g(index)
    295                 lat_scat(ij,jj) = rlat_g(index)
    296              ENDDO
    297           ENDDO
    298           lon_scat(:,1) = lon_scat(:,2)
    299           lat_scat(:,1) = rlat_g(1)
    300           lon_scat(:,nbp_lat) = lon_scat(:,2)
    301           lat_scat(:,nbp_lat) = rlat_g(klon_glo)
    302        ENDIF
     340           ENDIF
     341         ENDIF
     342       
     343         IF ((.NOT. ALLOCATED(lon_scat))) THEN
     344            ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error)
     345            IF (error /= 0) THEN
     346               abort_message='Pb allocation lon_scat'
     347               CALL abort_physic(modname,abort_message,1)
     348            ENDIF
     349         ENDIF
     350         IF ((.NOT. ALLOCATED(lat_scat))) THEN
     351            ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error)
     352            IF (error /= 0) THEN
     353               abort_message='Pb allocation lat_scat'
     354               CALL abort_physic(modname,abort_message,1)
     355            ENDIF
     356         ENDIF
     357         lon_scat = 0.
     358         lat_scat = 0.
     359         DO igrid = 1, knon
     360            index = knindex(igrid)
     361            lalo(igrid,2) = rlon(index)
     362            lalo(igrid,1) = rlat(index)
     363            bounds_lalo(igrid,:,2)=boundslon(index,:)*180./PI
     364            bounds_lalo(igrid,:,1)=boundslat(index,:)*180./PI
     365         ENDDO
     366
     367       
     368       
     369         CALL Gather(rlon,rlon_g)
     370         CALL Gather(rlat,rlat_g)
     371
     372         IF (is_mpi_root) THEN
     373            index = 1
     374            DO jj = 2, nbp_lat-1
     375               DO ij = 1, nbp_lon
     376                  index = index + 1
     377                  lon_scat(ij,jj) = rlon_g(index)
     378                  lat_scat(ij,jj) = rlat_g(index)
     379               ENDDO
     380            ENDDO
     381            lon_scat(:,1) = lon_scat(:,2)
     382            lat_scat(:,1) = rlat_g(1)
     383            lon_scat(:,nbp_lat) = lon_scat(:,2)
     384            lat_scat(:,nbp_lat) = rlat_g(klon_glo)
     385         ENDIF
    303386   
    304        CALL bcast(lon_scat)
    305        CALL bcast(lat_scat)
     387         CALL bcast(lon_scat)
     388         CALL bcast(lat_scat)
     389       
     390       ENDIF
    306391!
    307392! Allouer et initialiser le tableau des voisins et des fraction de continents
    308393!
    309        IF ( (.NOT.ALLOCATED(neighbours))) THEN
    310           ALLOCATE(neighbours(knon,8), stat = error)
    311           IF (error /= 0) THEN
    312              abort_message='Pb allocation neighbours'
    313              CALL abort_physic(modname,abort_message,1)
    314           ENDIF
    315        ENDIF
    316        neighbours = -1.
    317394       IF (( .NOT. ALLOCATED(contfrac))) THEN
    318395          ALLOCATE(contfrac(knon), stat = error)
    … …  
    329406
    330407
    331        CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
     408       IF (grid_type==regular_lonlat) THEN
     409 
     410         IF ( (.NOT.ALLOCATED(neighbours))) THEN
     411          ALLOCATE(neighbours(knon,8), stat = error)
     412          IF (error /= 0) THEN
     413             abort_message='Pb allocation neighbours'
     414             CALL abort_physic(modname,abort_message,1)
     415          ENDIF
     416         ENDIF
     417         neighbours = -1.
     418         CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
     419
     420       ELSE IF (grid_type==unstructured) THEN
     421 
     422         IF ( (.NOT.ALLOCATED(neighbours))) THEN
     423          ALLOCATE(neighbours(knon,12), stat = error)
     424          IF (error /= 0) THEN
     425             abort_message='Pb allocation neighbours'
     426             CALL abort_physic(modname,abort_message,1)
     427          ENDIF
     428         ENDIF
     429         neighbours = -1.
     430 
     431       ENDIF
     432         
    332433
    333434!
    … …  
    340441          ENDIF
    341442       ENDIF
    342        DO igrid = 1, knon
    343           ij = knindex(igrid)
    344           resolution(igrid,1) = dx(ij)
    345           resolution(igrid,2) = dy(ij)
    346        ENDDO
    347      
     443       
     444       IF (grid_type==regular_lonlat) THEN
     445         DO igrid = 1, knon
     446            ij = knindex(igrid)
     447            resolution(igrid,1) = dx(ij)
     448           resolution(igrid,2) = dy(ij)
     449         ENDDO
     450       ENDIF
     451       
    348452       ALLOCATE(coastalflow(klon), stat = error)
    349453       IF (error /= 0) THEN
    … …  
    397501    IF (debut) THEN
    398502       CALL Init_orchidee_index(knon,knindex,offset,ktindex)
    399        CALL Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank)
     503       CALL Get_orchidee_communicator(orch_comm,orch_mpi_size,orch_mpi_rank, orch_omp_size,orch_omp_rank)
     504
     505       IF (grid_type==unstructured) THEN
     506         IF (knon==0) THEN
     507           begin=1
     508           end=0
     509         ELSE
     510           begin=offset+1
     511           end=offset+ktindex(knon)
     512         ENDIF
     513       
     514         IF (orch_mpi_rank==orch_mpi_size-1 .AND. orch_omp_rank==orch_omp_size-1) end=nbp_lon*nbp_lat
     515         
     516         ALLOCATE(lalo(end-begin+1,2))
     517         ALLOCATE(bounds_lalo(end-begin+1,nvertex,2))
     518         ALLOCATE(ind_cell(end-begin+1))
     519         
     520         ALLOCATE(longitude_glo(klon_glo))
     521         CALL gather(longitude,longitude_glo)
     522         CALL bcast(longitude_glo)
     523         lalo(:,2)=longitude_glo(begin:end)*180./PI
     524 
     525         ALLOCATE(latitude_glo(klon_glo))
     526         CALL gather(latitude,latitude_glo)
     527         CALL bcast(latitude_glo)
     528         lalo(:,1)=latitude_glo(begin:end)*180./PI
     529
     530         ALLOCATE(boundslon_glo(klon_glo,nvertex))
     531         CALL gather(boundslon,boundslon_glo)
     532         CALL bcast(boundslon_glo)
     533         bounds_lalo(:,:,2)=boundslon_glo(begin:end,:)*180./PI
     534 
     535         ALLOCATE(boundslat_glo(klon_glo,nvertex))
     536         CALL gather(boundslat,boundslat_glo)
     537         CALL bcast(boundslat_glo)
     538         bounds_lalo(:,:,1)=boundslat_glo(begin:end,:)*180./PI
     539         
     540         ALLOCATE(ind_cell_glo_glo(klon_glo))
     541         CALL gather(ind_cell_glo,ind_cell_glo_glo)
     542         CALL bcast(ind_cell_glo_glo)
     543         ind_cell(:)=ind_cell_glo_glo(begin:end)
     544         
     545       ENDIF
    400546       CALL Init_synchro_omp
     547
     548!$OMP BARRIER
    401549       
    402550       IF (knon > 0) THEN
    403551#ifdef CPP_VEGET
    404          CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm)
     552         CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm,grid=grid_type)
    405553#endif
    406554       ENDIF
    407555
    408        
    409        IF (knon > 0) THEN
    410 
    411          print *,'OB before intersurf=', SIZE(cfname_in), SIZE(cfname_out)
     556       CALL Synchro_omp
     557
     558       
     559       IF (knon > 0) THEN
     560
    412561#ifdef CPP_VEGET
     562
    413563         CALL intersurf_initialize_gathered (itime+itau_phy-1, nbp_lon, nbp_lat, knon, ktindex, dtime, &
    414564               lrestart_read, lrestart_write, lalo, contfrac, neighbours, resolution, date0, &
    … …  
    418568               evap, fluxsens, fluxlat, coastalflow, riverflow, &
    419569               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0m_new, &   
    420 ! >> PC
    421                !lon_scat, lat_scat, q2m, t2m, z0h_new, nvm_orch)
    422                lon_scat, lat_scat, q2m, t2m, z0h_new, nvm_orch, &
     570               lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon), nvm_orch, &
     571               grid=grid_type, bounds_latlon=bounds_lalo, cell_area=area, ind_cell_glo=ind_cell, &
    423572               field_out_names=cfname_out, field_in_names=cfname_in(1:nbcf_in_orc))
    424 ! << PC
    425573#endif         
    426574       ENDIF
    … …  
    434582!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
    435583    swdown_vrai(1:knon) = swdown(1:knon)
     584!$OMP BARRIER
    436585
    437586    IF (knon > 0) THEN
    … …  
    450599            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
    451600            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0m_new(1:knon), &
    452             lon_scat, lat_scat, q2m, t2m, z0h_new(1:knon),&
     601            lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon),&
    453602            veget(1:knon,:),lai(1:knon,:),height(1:knon,:),&
    454603            fields_out=yfields_out(1:knon,1:nbcf_out),  &
    … …  
    542691!
    543692
    544   SUBROUTINE Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank)
     693  SUBROUTINE Get_orchidee_communicator(orch_comm, orch_mpi_size, orch_mpi_rank, orch_omp_size,orch_omp_rank)
    545694  USE  mod_surf_para
    546695     
    … …  
    550699
    551700    INTEGER,INTENT(OUT) :: orch_comm
     701    INTEGER,INTENT(OUT) :: orch_mpi_size
     702    INTEGER,INTENT(OUT) :: orch_mpi_rank
    552703    INTEGER,INTENT(OUT) :: orch_omp_size
    553704    INTEGER,INTENT(OUT) :: orch_omp_rank
    … …  
    568719#ifdef CPP_MPI   
    569720      CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
     721      CALL MPI_COMM_SIZE(orch_comm,orch_mpi_size,ierr)
     722      CALL MPI_COMM_RANK(orch_comm,orch_mpi_rank,ierr)
    570723#endif
    571724   
    … …  
    696849#endif
    697850#endif
     851#endif
    698852END MODULE surf_land_orchidee_mod

  • LMDZ6/branches/Ocean_skin/libf/phylmd/surf_land_orchidee_noz0h_mod.F90

    r3102 r3605  
    440440    IF (knon > 0) THEN
    441441#ifdef CPP_VEGET   
     442
    442443       CALL intersurf_main (itime+itau_phy, nbp_lon, nbp_lat, knon, ktindex, dtime,  &
    443444            lrestart_read, lrestart_write, lalo, &
    … …  
    448449            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
    449450            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
    450             lon_scat, lat_scat, q2m, t2m, coszang=yrmu0(1:knon))
     451            lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), coszang=yrmu0(1:knon))
    451452#endif       
    452453    ENDIF

  • LMDZ6/branches/Ocean_skin/libf/phylmd/thermcell_main.F90

    r2387 r3605  
    440440!
    441441      if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
    442 !IM 140508   CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
    443 
    444 ! Gestion temporaire de plusieurs appels à thermcell_plume au travers
    445 ! de la variable iflag_thermals
    446 
    447 !      print*,'THERM thermcell_main iflag_thermals_ed=',iflag_thermals_ed
     442
     443!=====================================================================
     444! Old version of thermcell_plume in thermcell_plume_6A.F90
     445! It includes both thermcell_plume_6A and thermcell_plume_5B corresponding
     446! to the 5B and 6A versions used for CMIP5 and CMIP6.
     447! The latest was previously named thermcellV1_plume.
     448! The new thermcell_plume is a clean version (removing obsolete
     449! options) of thermcell_plume_6A.
     450! The 3 versions are controled by
     451! flag_thermals_ed <= 9 thermcell_plume_6A
     452!                  <= 19 thermcell_plume_5B
     453!                  else thermcell_plume (default 20 for convergence with 6A)
     454! Fredho
     455!=====================================================================
     456
    448457      if (iflag_thermals_ed<=9) then
    449458!         print*,'THERM NOUVELLE/NOUVELLE Arnaud'
     459         CALL thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
     460     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
     461     &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
     462     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
     463     &    ,lev_out,lunout1,igout)
     464
     465      elseif (iflag_thermals_ed<=19) then
     466!        print*,'THERM RIO et al 2010, version d Arnaud'
     467         CALL thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
     468     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
     469     &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
     470     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
     471     &    ,lev_out,lunout1,igout)
     472      else
    450473         CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
    451474     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
    … …  
    453476     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
    454477     &    ,lev_out,lunout1,igout)
    455 
    456       elseif (iflag_thermals_ed>9) then
    457 !        print*,'THERM RIO et al 2010, version d Arnaud'
    458          CALL thermcellV1_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
    459      &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
    460      &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
    461      &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
    462      &    ,lev_out,lunout1,igout)
    463 
    464478      endif
    465479

  • LMDZ6/branches/Ocean_skin/libf/phylmd/tracco2i_mod.F90

    r3421 r3605  
    22!
    33! This module does the work for the interactive CO2 tracers
     4! Authors: Patricia Cadule and Olivier Boucher
     5!
     6! Purpose and description:
     7!  -----------------------
     8! Main routine for the interactive carbon cycle
     9! Gather all carbon fluxes and emissions from ORCHIDEE, PISCES and fossil fuel
     10! Compute the net flux in source field which is used in phytrac
     11! Compute global CO2 mixing ratio for radiation scheme if option is activated
     12! Redistribute CO2 evenly over the atmosphere if transport is desactivated
    413!
    514CONTAINS
    … …  
    1019
    1120    USE dimphy
    12     USE infotrac
    13     USE geometry_mod, ONLY : cell_area
    14     USE carbon_cycle_mod, ONLY : nbcf_in, fields_in, cfname_in, fco2_ocn_day, fco2_ff, fco2_bb
     21    USE infotrac_phy
     22    USE geometry_mod, ONLY: cell_area
     23    USE carbon_cycle_mod, ONLY: carbon_cycle_init
     24    USE carbon_cycle_mod, ONLY: id_CO2, nbcf_in, fields_in, cfname_in
     25    USE carbon_cycle_mod, ONLY: fco2_ocn_day, fco2_ff, fco2_bb, fco2_land, fco2_ocean
     26    USE carbon_cycle_mod, ONLY: fco2_land_nbp, fco2_land_nep, fco2_land_fLuc
     27    USE carbon_cycle_mod, ONLY: fco2_land_fwoodharvest, fco2_land_fHarvest
     28    USE carbon_cycle_mod, ONLY: carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, RCO2_glo, RCO2_tot
    1529    USE mod_grid_phy_lmdz
    16     USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
     30    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
    1731    USE mod_phys_lmdz_para, ONLY: gather, bcast, scatter
    1832    USE phys_cal_mod
     33    USE phys_state_var_mod, ONLY: pctsrf
     34    USE indice_sol_mod, ONLY: nbsrf, is_ter, is_lic, is_oce, is_sic
    1935
    2036    IMPLICIT NONE
    … …  
    4561!----------------
    4662
    47     INTEGER, PARAMETER :: id_CO2=1              !--temporaire OB -- to be changed
    4863    INTEGER                        :: it, k, i, nb
    4964    REAL, DIMENSION(klon,klev)     :: m_air     ! mass of air in every grid box [kg]
    50     REAL, DIMENSION(klon)          :: co2land   ! surface land CO2 emissions [kg CO2/m2/s]
    51     REAL, DIMENSION(klon)          :: co2ocean  ! surface ocean CO2 emissions [kg CO2/m2/s]
    5265    REAL, DIMENSION(klon_glo,klev) :: co2_glo   ! variable temporaire sur la grille global
    5366    REAL, DIMENSION(klon_glo,klev) :: m_air_glo ! variable temporaire sur la grille global
    5467
    55 
    56     INTEGER, SAVE :: mth_pre=0
    57 !$OMP THREADPRIVATE(mth_pre)
    58     REAL, SAVE :: RCO2_glo
    59 !$OMP THREADPRIVATE(RCO2_glo)
     68    LOGICAL, SAVE :: check_fCO2_nbp_in_cfname
     69!$OMP THREADPRIVATE(check_fCO2_nbp_in_cfname)
     70    INTEGER, SAVE :: day_pre=-1
     71!$OMP THREADPRIVATE(day_pre)
    6072
    6173    IF (is_mpi_root) THEN
    … …  
    6779!--convert 280 ppm into kg CO2 / kg air
    6880    IF (debutphy) THEN
     81
     82! Initialisation de module carbon_cycle_mod
     83      IF (carbon_cycle_cpl) THEN
     84        CALL carbon_cycle_init()
     85      ENDIF
     86
     87! Initialisation de tr_seri(id_CO2) si pas initialise
    6988      IF (MAXVAL(tr_seri(:,:,id_CO2)).LT.1.e-15) THEN
    70         tr_seri(:,:,id_CO2)=280.e-6/RMD*RMCO2
     89        tr_seri(:,:,id_CO2)=co2_ppm0*1.e-6/RMD*RMCO2 !--initialised from co2_ppm0 in rdem
    7190      ENDIF
     91
     92!--check if fCO2_nbp is in
     93      check_fCO2_nbp_in_cfname=.FALSE.
     94      DO nb=1, nbcf_in
     95        IF (cfname_in(nb)=="fCO2_nbp") check_fCO2_nbp_in_cfname=.TRUE.
     96      ENDDO
     97
    7298    ENDIF
    7399
    … …  
    85111
    86112!--retrieving land and ocean CO2 flux
    87 !--fCO2_nep comes in unit of g CO2 m-2 dt_stomate-1
    88 !--this needs to be changed in ORCHIDEE
    89     co2land(:)=0.0
    90     co2ocean(:)=0.0
     113    fco2_land(:)=0.0
     114    fco2_ocean(:)=0.0
     115    fco2_land_nbp(:)=0.
     116    fco2_land_nep(:)=0.
     117    fco2_land_fLuc(:)=0.
     118    fco2_land_fwoodharvest(:)=0.
     119    fco2_land_fHarvest(:)=0.
     120
    91121    DO nb=1, nbcf_in
    92       IF (cfname_in(nb) == "fCO2_nep" )   co2land(:)=fields_in(:,nb)*RMCO2/RMC/86400./1000.
    93       !!IF (cfname_in(nb) == "fCO2_fgco2" ) co2ocean(:)=fco2_ocn_day(:) !--for now
     122
     123      SELECT CASE(cfname_in(nb))
     124!--dealing with the different fluxes coming from ORCHIDEE
     125!--fluxes come in unit of kg C m-2 s-1 is converted into kg CO2 m-2 s-1
     126      CASE("fCO2_nep")
     127          fco2_land_nep(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
     128      CASE("fCO2_fLuc")
     129          fco2_land_fLuc(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
     130      CASE("fCO2_fwoodharvest")
     131          fco2_land_fwoodharvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
     132      CASE("fCO2_fHarvest")
     133          fco2_land_fHarvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
     134      CASE("fCO2_nbp")
     135          fco2_land_nbp(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
     136!--fCO2_fco2_ocn comes in unit of mol C02 m-2 s-1 is converted into kg CO2 m-2 s-1 + change sign
     137      CASE("fCO2_fgco2")
     138          fco2_ocean(:)=-1.*fco2_ocn_day(:)*RMCO2/1.e3*(pctsrf(:,is_oce)+pctsrf(:,is_sic))
     139      END SELECT
     140
    94141    ENDDO
    95142
    96 !--preparing the net anthropogenic flux at the surface for mixing layer
    97 !--unit kg CO2 / m2 / s
    98     source(:,id_CO2)=fco2_ff(:)+fco2_bb(:)+co2land(:)+co2ocean(:)
     143!--if fCO2_nbp is transferred we use it, otherwise we use the sum of what has been passed from ORCHIDEE
     144    IF (check_fCO2_nbp_in_cfname)  THEN
     145       fco2_land(:)=fco2_land_nbp(:)
     146    ELSE
     147       fco2_land(:)=fco2_land_nep(:)+fco2_land_fLuc(:)+fco2_land_fwoodharvest(:)+fco2_land_fHarvest(:)
     148    ENDIF
     149
     150!!--preparing the net anthropogenic flux at the surface for mixing layer
     151!!--unit kg CO2 / m2 / s
     152!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ff) ',MAXVAL(fco2_ff)
     153!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ff) ',MINVAL(fco2_ff)
     154!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_bb) ',MAXVAL(fco2_bb)
     155!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_bb) ',MINVAL(fco2_bb)
     156!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_land) ',MAXVAL(fco2_land)
     157!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_land) ',MINVAL(fco2_land)
     158!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ocean) ',MAXVAL(fco2_ocean)
     159!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ocean) ',MINVAL(fco2_ocean)
     160!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(source(:,id_CO2)) ',MAXVAL(source(:,id_CO2))
     161!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(source(:,id_CO2)) ',MINVAL(source(:,id_CO2))
     162!
     163!--build final source term for CO2
     164    source(:,id_CO2)=fco2_ff(:)+fco2_bb(:)+fco2_land(:)+fco2_ocean(:)
    99165
    100166!--computing global mean CO2 for radiation
    101 !--every timestep for now but enough every month
    102 !    IF (debutphy.OR.mth_cur.NE.mth_pre) THEN
     167!--for every timestep comment out the IF ENDIF statements
     168!--otherwise this is updated every day
     169    IF (debutphy.OR.day_cur.NE.day_pre) THEN
     170
    103171      CALL gather(tr_seri(:,:,id_CO2),co2_glo)
    104172      CALL gather(m_air,m_air_glo)
     173
    105174!$OMP MASTER
    106 !--conversion from kg CO2/kg air into ppm
     175
     176!--compute a global mean CO2 value and print its value in ppm
    107177       IF (is_mpi_root) THEN
    108          RCO2_glo=SUM(co2_glo*m_air_glo)/SUM(m_air_glo)*1.e6*RMD/RMCO2
     178         RCO2_tot=SUM(co2_glo*m_air_glo)  !--unit kg CO2
     179         RCO2_glo=RCO2_tot/SUM(m_air_glo) !--unit kg CO2 / kg air
     180         PRINT *,'tracco2i: global CO2 in ppm =', RCO2_glo*1.e6*RMD/RMCO2
     181         PRINT *,'tracco2i: total CO2 in kg =', RCO2_tot
    109182       ENDIF
    110        PRINT *,'toto in tracco2i: global CO2 in ppm =', RCO2_glo
    111183!$OMP END MASTER
    112184       CALL bcast(RCO2_glo)
    113        mth_pre=mth_cur
    114 !    ENDIF
     185       day_pre=day_cur
     186!--if not carbon_cycle_tr, then we reinitialize the CO2 each day to its global mean value
     187       IF (.NOT.carbon_cycle_tr) THEN
     188         tr_seri(:,:,id_CO2)=RCO2_glo
     189       ENDIF
     190    ENDIF
    115191
    116192  END SUBROUTINE tracco2i
    … …  
    119195
    120196    USE dimphy
    121     USE infotrac
     197    USE infotrac_phy
    122198    USE geometry_mod, ONLY : cell_area
    123199    USE mod_grid_phy_lmdz
    … …  
    129205    USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
    130206
    131     USE carbon_cycle_mod, ONLY : fco2_ff, fco2_bb
     207    USE carbon_cycle_mod, ONLY : fco2_ff, fco2_bb, fco2_land, fco2_ocean
    132208
    133209    IMPLICIT NONE
    … …  
    150226!! may be controlled via the .def later on
    151227!! also co2bb for now comes from ORCHIDEE
    152     LOGICAL, PARAMETER :: readco2ff=.TRUE., readco2bb=.FALSE.
     228    LOGICAL, PARAMETER :: readco2ff=.TRUE.
     229!! this should be left to FALSE for now
     230    LOGICAL, PARAMETER :: readco2bb=.FALSE.
     231
     232    CHARACTER (len = 20) :: modname = 'tracco2i.co2_emissions'
     233    CHARACTER (len = 80) :: abort_message
    153234
    154235    IF (debutphy) THEN
    … …  
    173254        n_glo = size(vector)
    174255        IF (n_glo.NE.klon_glo) THEN
    175            PRINT *,'sflx_lmdz_co2_ff: le nombre de points n est pas egal a klon_glo'
    176            STOP
     256           abort_message='sflx_lmdz_co2_ff: le nombre de points n est pas egal a klon_glo'
     257           CALL abort_physic(modname,abort_message,1)
    177258        ENDIF
    178259
    … …  
    181262        n_month = size(time)
    182263        IF (n_month.NE.12) THEN
    183            PRINT *,'sflx_lmdz_co2_ff: le nombre de month n est pas egal a 12'
    184            STOP
     264           abort_message='sflx_lmdz_co2_ff: le nombre de month n est pas egal a 12'
     265           CALL abort_physic(modname,abort_message,1)
    185266        ENDIF
    186267
    … …  
    196277
    197278!--reading CO2 biomass burning emissions
     279!--using it will be inconsistent with treatment in ORCHIDEE
    198280      IF (readco2bb) THEN
    199281
    … …  
    205287      n_glo = size(vector)
    206288      IF (n_glo.NE.klon_glo) THEN
    207          PRINT *,'sflx_lmdz_co2_bb: le nombre de points n est pas egal a klon_glo'
    208          STOP
     289         abort_message='sflx_lmdz_co2_bb: le nombre de points n est pas egal a klon_glo'
     290         CALL abort_physic(modname,abort_message,1)
    209291      ENDIF
    210292
    … …  
    213295      n_month = size(time)
    214296      IF (n_month.NE.12) THEN
    215          PRINT *,'sflx_lmdz_co2_bb: le nombre de month n est pas egal a 12'
    216          STOP
     297         abort_message='sflx_lmdz_co2_bb: le nombre de month n est pas egal a 12'
     298         CALL abort_physic(modname,abort_message,1)
    217299      ENDIF
    218300
    … …  
    247329    PRINT *,'probleme avec le mois dans co2_ini =', mth_cur
    248330  ENDIF
    249   IF (.NOT.ALLOCATED(fco2_ff)) ALLOCATE(fco2_ff(klon))
    250   IF (.NOT.ALLOCATED(fco2_bb)) ALLOCATE(fco2_bb(klon))
     331
    251332  fco2_ff(:) = flx_co2ff(:,mth_cur)
    252333  fco2_bb(:) = flx_co2bb(:,mth_cur)

  • LMDZ6/branches/Ocean_skin/libf/phylmd/traclmdz_mod.F90

    r2320 r3605  
    9292    USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz
    9393    USE press_coefoz_m, ONLY: press_coefoz
    94     USE carbon_cycle_mod, ONLY : carbon_cycle_init, carbon_cycle_tr, carbon_cycle_cpl
    9594    USE mod_grid_phy_lmdz
    9695    USE mod_phys_lmdz_para
    … …  
    285284
    286285!
    287 ! Initialisation de module carbon_cycle_mod
    288 ! ----------------------------------------------
    289     IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
    290        CALL carbon_cycle_init(tr_seri, pdtphys, aerosol, radio)
    291     END IF
    292 
    293286! Check if all tracers have restart values
    294287! ----------------------------------------------
    … …  
    346339    USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz
    347340    USE o3_chem_m, ONLY: o3_chem
    348     USE carbon_cycle_mod, ONLY : carbon_cycle, carbon_cycle_tr, carbon_cycle_cpl
    349341    USE indice_sol_mod
    350342
    … …  
    612604    END IF
    613605
    614 !======================================================================
    615 !   Calcul de cycle de carbon
    616 !======================================================================
    617     IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
    618        CALL carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source)
    619     END IF
    620 
    621606  END SUBROUTINE traclmdz
    622607

  • LMDZ6/branches/Ocean_skin/libf/phylmd/undefSTD.F90

    r2346 r3605  
    4343  ! PARAMETER(klevSTD=17)
    4444  INTEGER itap
    45   ! REAL dtime
    4645
    4746  ! variables locales
    … …  
    6766
    6867
    69     ! calcul variables tous les freq_calNMC(n)/dtime pas de temps
     68    ! calcul variables tous les freq_calNMC(n)/phys_tstep pas de temps
    7069    ! de la physique
    7170
    72     IF (mod(itap,nint(freq_calnmc(n)/dtime))==0) THEN
     71    IF (mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN
    7372      DO k = 1, nlevstd
    7473        DO i = 1, klon
    … …  
    103102      END DO !k
    104103
    105     END IF !MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0
     104    END IF !MOD(itap,NINT(freq_calNMC(n)/phys_tstep)).EQ.0
    106105
    107106  END DO !n

  • LMDZ6/branches/Ocean_skin/libf/phylmd/wake.F90

    r3252 r3605  
    196196  INTEGER                                               :: nsub
    197197  REAL                                                  :: dtimesub
    198   REAL                                                  :: wdensmin
     198  REAL, SAVE                                            :: wdensmin
     199  !$OMP THREADPRIVATE(wdensmin)
    199200  REAL, SAVE                                            :: sigmad, hwmin, wapecut, cstart
    200201  !$OMP THREADPRIVATE(sigmad, hwmin, wapecut, cstart)
    201   REAL                                                  :: sigmaw_max
    202   REAL                                                  :: dens_rate
     202  REAL, SAVE                                            :: sigmaw_max
     203  !$OMP THREADPRIVATE(sigmaw_max) 
     204  REAL, SAVE                                            :: dens_rate
     205  !$OMP THREADPRIVATE(dens_rate)
    203206  REAL                                                  :: wdens0
    204207  ! IM 080208
    … …  
    10151018
    10161019    IF (iflag_wk_pop_dyn >= 1) THEN
     1020!    The variable "death_rate" is significant only when iflag_wk_pop_dyn = 0.
     1021!    Here, it has to be set to zero.
     1022      death_rate(:) = 0.
    10171023
    10181024      IF (iflag_wk_act ==2) THEN

  • LMDZ6/branches/Ocean_skin/libf/phylmd/write_histrac.h

    r2265 r3605  
    88     
    99     CALL histwrite_phy(nid_tra,.FALSE.,"phis",itau_w,pphis)
    10      CALL histwrite_phy(nid_tra,.FALSE.,"aire",itau_w,airephy)
     10     CALL histwrite_phy(nid_tra,.FALSE.,"aire",itau_w,cell_area)
    1111     CALL histwrite_phy(nid_tra,.FALSE.,"zmasse",itau_w,zmasse)
    1212! RomP >>>

  • LMDZ6/branches/Ocean_skin/libf/phylmd/yamada4.F90

    r3041 r3605  
    152152  !$OMP THREADPRIVATE(firstcall)
    153153
     154  CHARACTER (len = 20) :: modname = 'yamada4'
     155  CHARACTER (len = 80) :: abort_message
     156
    154157
    155158
    … …  
    199202    ENDIF
    200203
    201     PRINT*,'YAMADA4 RIc, RIfc, Sm_min, Alpha_min',ric,rifc,seuilsm,seuilalpha
     204    WRITE(lunout,*)'YAMADA4 RIc, RIfc, Sm_min, Alpha_min',ric,rifc,seuilsm,seuilalpha
    202205    firstcall = .FALSE.
    203206    CALL getin_p('lmixmin',lmixmin)
    … …  
    216219
    217220  IF (.NOT. (iflag_pbl>=6 .AND. iflag_pbl<=12)) THEN
    218     STOP 'probleme de coherence dans appel a MY'
     221    abort_message='probleme de coherence dans appel a MY'
     222    CALL abort_physic(modname,abort_message,1)
    219223  END IF
    220224
    … …  
    537541
    538542  ELSE
    539     STOP 'Cas nom prevu dans yamada4'
     543     abort_message='Cas nom prevu dans yamada4'
     544     CALL abort_physic(modname,abort_message,1)
    540545
    541546  END IF ! Fin du cas 8
    … …  
    590595
    591596  IF (prt_level>1) THEN
    592     PRINT *, 'YAMADA4 0'
     597    WRITE(lunout,*) 'YAMADA4 0'
    593598  END IF
    594599
    … …  
    660665
    661666  IF (prt_level>1) THEN
    662     PRINT *, 'YAMADA4 1'
     667    WRITE(lunout,*)'YAMADA4 1'
    663668  END IF !(prt_level>1) THEN
    664669
    … …  
    734739  IMPLICIT NONE
    735740 
    736   include "dimensions.h"
    737 
    738741!    vdif_q2: subroutine qui calcule la diffusion de la TKE par la TKE
    739742!             avec un schema implicite en temps avec
    … …  
    825828  IMPLICIT NONE
    826829
    827   include "dimensions.h"
    828 !
    829830! vdif_q2e: subroutine qui calcule la diffusion de TKE par la TKE
    830831!           avec un schema explicite en temps
Note: See TracChangeset for help on using the changeset viewer.