Changeset 5202 for LMDZ6/branches/cirrus/libf

Timestamp:

Sep 20, 2024, 12:32:04 PM (4 months ago)

Author:

Laurent Fairhead

Message:

Updating cirrus branch to trunk revision 5171

Location:

LMDZ6/branches/cirrus

Files:

• . (modified) (1 prop)
• libf/dyn3d/check_isotopes.F90 (modified) (2 diffs)
• libf/dyn3d/conf_gcm.F90 (modified) (3 diffs)
• libf/dyn3d/dynetat0.F90 (modified) (2 diffs)
• libf/dyn3d/dynredem_mod.F90 (modified) (1 diff)
• libf/dyn3d/iniacademic.F90 (modified) (2 diffs)
• libf/dyn3d/logic_mod.F90 (modified) (1 diff)
• libf/dyn3d/qminimum.F (modified) (6 diffs)
• libf/dyn3d/vlspltqs.F (modified) (2 diffs)
• libf/dyn3d_common/infotrac.F90 (modified) (13 diffs)
• libf/dyn3dmem/check_isotopes_loc.F90 (modified) (2 diffs)
• libf/dyn3dmem/conf_gcm.F90 (modified) (3 diffs)
• libf/dyn3dmem/dynetat0_loc.F90 (modified) (3 diffs)
• libf/dyn3dmem/dynredem_mod.F90 (modified) (1 diff)
• libf/dyn3dmem/filtreg_p.F (deleted)
• libf/dyn3dmem/gcm.F90 (modified) (1 diff)
• libf/dyn3dmem/iniacademic_loc.F90 (modified) (2 diffs)
• libf/dyn3dmem/logic_mod.F90 (modified) (2 diffs)
• libf/dyn3dmem/qminimum_loc.F (modified) (15 diffs)
• libf/dyn3dmem/vlspltgen_loc.F (modified) (3 diffs)
• libf/dyn3dmem/vlspltqs_loc.F (modified) (1 diff)
• libf/misc/readTracFiles_mod.f90 (modified) (66 diffs)
• libf/misc/strings_mod.F90 (modified) (67 diffs)
• libf/obsolete/filtreg_p.F (copied) (copied from LMDZ6/trunk/libf/obsolete/filtreg_p.F)
• libf/phylmd/Dust/phys_output_write_spl_mod.F90 (modified) (4 diffs)
• libf/phylmd/StratAer/aer_sedimnt.F90 (modified) (2 diffs)
• libf/phylmd/StratAer/aerophys.F90 (modified) (1 diff)
• libf/phylmd/StratAer/coagulate.F90 (modified) (12 diffs)
• libf/phylmd/StratAer/cond_evap_tstep_mod.F90 (modified) (8 diffs)
• libf/phylmd/StratAer/micphy_tstep.F90 (modified) (9 diffs)
• libf/phylmd/StratAer/miecalc_aer.F90 (modified) (2 diffs)
• libf/phylmd/StratAer/nucleation_tstep_mod.F90 (modified) (2 diffs)
• libf/phylmd/StratAer/strataer_local_var_mod.F90 (modified) (6 diffs)
• libf/phylmd/StratAer/strataer_nuc_mod.F90 (modified) (2 diffs)
• libf/phylmd/StratAer/sulfate_aer_mod.F90 (modified) (3 diffs)
• libf/phylmd/StratAer/traccoag_mod.F90 (modified) (7 diffs)
• libf/phylmd/add_phys_tend_mod.F90 (modified) (1 diff)
• libf/phylmd/cdrag_mod.F90 (modified) (2 diffs)
• libf/phylmd/clesphys.h (modified) (2 diffs)
• libf/phylmd/coare30_flux_cnrm.F90 (deleted)
• libf/phylmd/coare30_flux_cnrm_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmd/coare30_flux_cnrm_mod.F90)
• libf/phylmd/coare_cp.F90 (deleted)
• libf/phylmd/coare_cp_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmd/coare_cp_mod.F90)
• libf/phylmd/cosp2 (deleted)
• libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.F90 (modified) (1 diff)
• libf/phylmd/ecrad/lmdz/radiation_setup.F90 (modified) (1 diff)
• libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.F90 (modified) (4 diffs)
• libf/phylmd/ecrad/radiation/radiation_mcica_lw.F90 (modified) (6 diffs)
• libf/phylmd/ecrad/radiation/radiation_mcica_sw.F90 (modified) (6 diffs)
• libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90 (modified) (6 diffs)
• libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90.or (modified) (7 diffs)
• libf/phylmd/ecrad/radiation/radiation_tripleclouds_sw.F90 (modified) (7 diffs)
• libf/phylmd/fonte_neige_mod.F90 (modified) (17 diffs)
• libf/phylmd/grid_index.F90 (copied) (copied from LMDZ6/trunk/libf/phylmd/grid_index.F90)
• libf/phylmd/infotrac_phy.F90 (modified) (13 diffs)
• libf/phylmd/lmdz_atke_exchange_coeff.F90 (modified) (13 diffs)
• libf/phylmd/lmdz_atke_turbulence_ini.F90 (modified) (8 diffs)
• libf/phylmd/lmdz_call_atke.F90 (modified) (5 diffs)
• libf/phylmd/lmdz_lscp.F90 (modified) (27 diffs)
• libf/phylmd/lmdz_lscp_ini.F90 (modified) (11 diffs)
• libf/phylmd/lmdz_lscp_poprecip.F90 (modified) (2 diffs)
• libf/phylmd/lmdz_lscp_tools.F90 (modified) (4 diffs)
• libf/phylmd/lmdz_thermcell_plume_6A.F90 (modified) (1 diff)
• libf/phylmd/ocean_forced_mod.F90 (modified) (16 diffs)
• libf/phylmd/pbl_surface_mod.F90 (modified) (74 diffs)
• libf/phylmd/phys_local_var_mod.F90 (modified) (38 diffs)
• libf/phylmd/phys_output_ctrlout_mod.F90 (modified) (5 diffs)
• libf/phylmd/phys_output_mod.F90 (modified) (7 diffs)
• libf/phylmd/phys_output_write_mod.F90 (modified) (21 diffs)
• libf/phylmd/phys_state_var_mod.F90 (modified) (3 diffs)
• libf/phylmd/physiq_mod.F90 (modified) (26 diffs)
• libf/phylmd/phystokenc_mod.F90 (modified) (1 diff)
• libf/phylmd/radlwsw_m.F90 (modified) (4 diffs)
• libf/phylmd/surf_land_bucket_mod.F90 (modified) (8 diffs)
• libf/phylmd/surf_land_mod.F90 (modified) (13 diffs)
• libf/phylmd/surf_landice_mod.F90 (modified) (13 diffs)
• libf/phylmd/surf_ocean_mod.F90 (modified) (7 diffs)
• libf/phylmd/surf_seaice_mod.F90 (modified) (6 diffs)
• libf/phylmdiso/add_phys_tend_mod.F90 (modified) (1 diff)
• libf/phylmdiso/add_wake_tend.F90 (modified) (4 diffs)
• libf/phylmdiso/coare30_flux_cnrm.F90 (deleted)
• libf/phylmdiso/coare30_flux_cnrm_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/coare30_flux_cnrm_mod.F90)
• libf/phylmdiso/coare_cp.F90 (deleted)
• libf/phylmdiso/coare_cp_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/coare_cp_mod.F90)
• libf/phylmdiso/cosp2 (deleted)
• libf/phylmdiso/fonte_neige_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/fonte_neige_mod.F90)
• libf/phylmdiso/isotopes_mod.F90 (modified) (11 diffs)
• libf/phylmdiso/isotopes_routines_mod.F90 (modified) (7 diffs)
• libf/phylmdiso/isotopes_verif_mod.F90 (modified) (1 diff)
• libf/phylmdiso/isotrac_routines_mod.F90 (modified) (1 diff)
• libf/phylmdiso/ocean_forced_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/ocean_forced_mod.F90)
• libf/phylmdiso/output_physiqex_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/output_physiqex_mod.F90)
• libf/phylmdiso/pbl_surface_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/pbl_surface_mod.F90)
• libf/phylmdiso/phyetat0_mod.F90 (modified) (9 diffs)
• libf/phylmdiso/phys_local_var_mod.F90 (modified) (44 diffs)
• libf/phylmdiso/phys_output_ctrlout_mod.F90 (modified) (6 diffs)
• libf/phylmdiso/phys_output_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/phys_output_mod.F90)
• libf/phylmdiso/phys_output_var_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/phys_output_var_mod.F90)
• libf/phylmdiso/physiq_mod.F90 (modified) (75 diffs)
• libf/phylmdiso/physiqex_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/physiqex_mod.F90)
• libf/phylmdiso/reevap.F90 (modified) (4 diffs)
• libf/phylmdiso/surf_land_bucket_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_mod.F90)
• libf/phylmdiso/surf_land_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/surf_land_mod.F90)
• libf/phylmdiso/surf_landice_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/surf_landice_mod.F90)
• libf/phylmdiso/surf_ocean_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/surf_ocean_mod.F90)
• libf/phylmdiso/surf_seaice_mod.F90 (copied) (copied from LMDZ6/trunk/libf/phylmdiso/surf_seaice_mod.F90)

LMDZ6/branches/cirrus/libf/dyn3d/check_isotopes.F90

@@ -23 +23 @@
                              iso_O17, iso_HTO
    LOGICAL, SAVE :: first=.TRUE.
+   LOGICAL, PARAMETER :: tnat1=.TRUE.
 
    modname='check_isotopes'
@@ -34 +35 @@
       iso_O17 = strIdx(isoName,'H217O')
       iso_HTO = strIdx(isoName,'HTO')
-      IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1)
+      if (tnat1) then
+              tnat(:)=1.0
+      else
+         IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1)
+      endif
       first = .FALSE.
    END IF

LMDZ6/branches/cirrus/libf/dyn3d/conf_gcm.F90

@@ -18 +18 @@
   USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
                        ok_guide, ok_limit, ok_strato, purmats, read_start, &
-                       ysinus, read_orop
+                       ysinus, read_orop, adv_qsat_liq
   USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
                        alphax,alphay,taux,tauy
@@ -606 +606 @@
      type_trac = 'lmdz'
      CALL getin('type_trac',type_trac)
+
+
+     !Config  Key  = adv_qsat_liq
+     !Config  Desc = option for qsat calculation in the dynamics
+     !Config  Def  = n 
+     !Config  Help = controls which phase is considered for qsat calculation 
+     !Config          
+     adv_qsat_liq = .FALSE.
+     CALL getin('adv_qsat_liq',adv_qsat_liq)
 
      !Config  Key  = ok_dynzon 
@@ -672 +681 @@
      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+     write(lunout,*)' adv_qsat_liq = ', adv_qsat_liq
   ELSE
      !Config  Key  = clon

LMDZ6/branches/cirrus/libf/dyn3d/dynetat0.F90

@@ -43 +43 @@
   REAL    :: time, tnat, alpha_ideal, tab_cntrl(length)    !--- RUN PARAMS TABLE
   LOGICAL :: lSkip, ll
+  LOGICAL,PARAMETER :: tnat1=.TRUE.
 !-------------------------------------------------------------------------------
   modname="dynetat0"
@@ -155 +156 @@
       iqParent = tracers(iq)%iqParent
       IF(tracers(iq)%iso_iZone == 0) THEN
-         IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
+         if (tnat1) then
+                 tnat=1.0
+                 alpha_ideal=1.0
+                 write(*,*) 'attention dans dynetat0: les alpha_ideal sont a 1'
+         else
+          IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
             CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1)
+         endif
          CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname)
          q(:,:,:,iq) = q(:,:,:,iqParent)*tnat*(q(:,:,:,iqParent)/30.e-3)**(alpha_ideal-1.)

LMDZ6/branches/cirrus/libf/dyn3d/dynredem_mod.F90

@@ -4 +4 @@
   PRIVATE
   PUBLIC :: dynredem_write_u, dynredem_write_v, dynredem_read_u, err
-  PUBLIC :: cre_var, get_var1, put_var1, put_var2, fil, modname, msg
+  PUBLIC :: cre_var, put_var1, put_var2, fil, modname, msg
   include "dimensions.h"
   include "paramet.h"

LMDZ6/branches/cirrus/libf/dyn3d/iniacademic.F90

@@ -80 +80 @@
 
   REAL zdtvr, tnat, alpha_ideal
+  LOGICAL,PARAMETER :: tnat1=.true.
   
   character(len=*),parameter :: modname="iniacademic"
@@ -321 +322 @@
               iqParent = tracers(iq)%iqParent
               IF(tracers(iq)%iso_iZone == 0) THEN
-                 IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
+                 if (tnat1) then
+                         tnat=1.0
+                         alpha_ideal=1.0
+                         write(*,*) 'Attention dans iniacademic: alpha_ideal=1'
+                 else
+                    IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
                     CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1)
+                 endif
                  q(:,:,iq) = q(:,:,iqParent)*tnat*(q(:,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-              ELSE
-                 q(:,:,iq) = q(:,:,iqIsoPha(iName,iPhase))
-              END IF
+              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
+                 IF(tracers(iq)%iso_iZone == 1) THEN
+                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
+                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
+                    q(:,:,iq) = q(:,:,iqIsoPha(iName,iPhase))
+                 else !IF(tracers(iq)%iso_iZone == 1) THEN
+                    q(:,:,iq) = 0.
+                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
+              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
            enddo
         else

LMDZ6/branches/cirrus/libf/dyn3d/logic_mod.F90

@@ -30 +30 @@
   LOGICAL hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
                  ! (only used if disvert_type==2)
+  LOGICAL adv_qsat_liq ! true if qsat is calculated alwats wrt liquid for
+                       ! adapted Van Leer advection scheme
   INTEGER iflag_phys ! type of physics to call: 0 none, 1: phy*** package,
                      ! 2: Held & Suarez, 101-200: aquaplanets & terraplanets

LMDZ6/branches/cirrus/libf/dyn3d/qminimum.F

@@ -28 +28 @@
 c     .................................................................
 c
+cDC iq_val and iq_liq are usable for q only, NOT for q_follow
+c   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
+c   water at hardcoded indices 1/2 in these variables
       INTEGER i, k, iq
       REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
@@ -58 +61 @@
 
       zx_defau_diag(:,:,:)=0.0
-      q_follow(:,:,1:2)=q(:,:,1:2)  
-      DO 1000 k = 1, llm
-        DO 1040 i = 1, ip1jmp1
+      q_follow(:,:,1)=q(:,:,iq_vap)  
+      q_follow(:,:,2)=q(:,:,iq_liq)  
+      DO k = 1, llm
+        DO i = 1, ip1jmp1
           if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
 
-              if (niso > 0) zx_defau_diag(i,k,iq_liq)=AMAX1
+            if (niso > 0) zx_defau_diag(i,k,2)=AMAX1
      :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
 
-             q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
-             q(i,k,iq_liq) = seuil_liq
-           endif
- 1040   CONTINUE
- 1000 CONTINUE
+            q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+            q(i,k,iq_liq) = seuil_liq
+          endif
+        ENDDO
+      ENDDO
 c
 c Quand l'eau vapeur est trop faible (ou negative), on complete
 c le defaut en prennant de l'eau vapeur de la couche au-dessous.
 c
-      iq = iq_vap
-c
       DO k = llm, 2, -1
 ccc      zx_abc = dpres(k) / dpres(k-1)
         DO i = 1, ip1jmp1
-          if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
+          if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then
 
-            if (niso > 0)
-     &        zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
+            if (niso > 0) zx_defau_diag(i,k,1)
+     &           = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
 
-            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
-     &                     deltap(i,k) / deltap(i,k-1)
-            q(i,k,iq)   =  seuil_vap  
+            q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap
+     &           -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
+            q(i,k,iq_vap)   =  seuil_vap  
+
           endif
         ENDDO
       ENDDO
+
 c
 c Quand il s'agit de la premiere couche au-dessus du sol, on
@@ -96 +100 @@
 c
       DO i = 1, ip1jmp1
-         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
-         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
+         q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
       ENDDO
       pompe = SSUM(ip1jmp1,zx_pump,1)
@@ -121 +125 @@
       DO i = 1,ip1jmp1
         if (zx_pump(i).gt.0.0) then
-          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
+          q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
         endif !if (zx_pump(i).gt.0.0) then
       enddo !DO i = 1,ip1jmp1
@@ -129 +133 @@
       do k=2,llm
         DO i = 1,ip1jmp1
-          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
+          if (zx_defau_diag(i,k,1).gt.0.0) then             
               ! on ajoute la vapeur en k              
               do ixt=1,ntiso
                q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :           +zx_defau_diag(i,k,iq_vap)
-     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
+     :           +zx_defau_diag(i,k,1)
+     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
                 
               ! et on la retranche en k-1
                q(i,k-1,iqIsoPha(ixt,iq_vap))=
      :            q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,iq_vap)
+     :              -zx_defau_diag(i,k,1)
      :              *deltap(i,k)/deltap(i,k-1)
      :              *q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              /q_follow(i,k-1,iq_vap)
+     :              /q_follow(i,k-1,1)
 
               enddo !do ixt=1,niso
-              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
-     :               +zx_defau_diag(i,k,iq_vap)
-              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
-     :               -zx_defau_diag(i,k,iq_vap)
+              q_follow(i,k,1)=   q_follow(i,k,1)
+     :               +zx_defau_diag(i,k,1)
+              q_follow(i,k-1,1)=   q_follow(i,k-1,1)
+     :               -zx_defau_diag(i,k,1)
      :              *deltap(i,k)/deltap(i,k-1)
-          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
         enddo !DO i = 1, ip1jmp1        
        enddo !do k=2,llm
@@ -161 +165 @@
         do k=1,llm
         DO i = 1,ip1jmp1
-          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
+          if (zx_defau_diag(i,k,2).gt.0.0) then
 
               ! on ajoute eau liquide en k en k              
               do ixt=1,ntiso
                q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq))
-     :              +zx_defau_diag(i,k,iq_liq)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,iq_vap)
+     :              +zx_defau_diag(i,k,2)
+     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
               ! et on la retranche à la vapeur en k
                q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,iq_liq)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,iq_vap)   
+     :              -zx_defau_diag(i,k,2)
+     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)   
               enddo !do ixt=1,niso
-              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
-     :               +zx_defau_diag(i,k,iq_liq)
-              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
-     :               -zx_defau_diag(i,k,iq_liq)
-          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+              q_follow(i,k,2)=   q_follow(i,k,2)
+     :               +zx_defau_diag(i,k,2)
+              q_follow(i,k,1)=   q_follow(i,k,1)
+     :               -zx_defau_diag(i,k,2)
+          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
         enddo !DO i = 1, ip1jmp1
        enddo !do k=2,llm  

LMDZ6/branches/cirrus/libf/dyn3d/vlspltqs.F

@@ -25 +25 @@
       
       USE comconst_mod, ONLY: cpp
-      
+      USE logic_mod, ONLY: adv_qsat_liq 
       IMPLICIT NONE
 c
@@ -92 +92 @@
          ENDDO
          DO ij = 1, ip1jmp1
-          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          IF (adv_qsat_liq) THEN
+             zdelta = 0.
+          ELSE
+             zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          ENDIF
           play   = 0.5*(p(ij,l)+p(ij,l+1))
           qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )

LMDZ6/branches/cirrus/libf/dyn3d_common/infotrac.F90

@@ -5 +5 @@
    USE       strings_mod, ONLY: msg, fmsg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse
    USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, setGeneration, itZonIso, nzone, tran0, isoZone, &
-        delPhase, niso, getKey, isot_type, readIsotopesFile, isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, &
-        addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate,   isoCheck, nbIso, ntiso, isoName
+        delPhase, niso, getKey, isot_type, processIsotopes,  isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, &
+        addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate,  iqWIsoPha, nbIso, ntiso, isoName, isoCheck
    IMPLICIT NONE
 
@@ -36 +36 @@
 !  |--------------------+-----------------------+-----------------+---------------+----------------------------|
 !  | water in different |    water tagging      |  water isotopes | other tracers | additional tracers moments |
-!  | phases: H2O_[glsb] |      isotopes         |                 |               |  for higher order schemes  |
+!  | phases: H2O_[gls]  |      isotopes         |                 |               |  for higher order schemes  |
 !  |--------------------+-----------------------+-----------------+---------------+----------------------------|
 !  |                    |                       |                 |               |                            |
@@ -65 +65 @@
 !  | longName    | Long name (with adv. scheme suffix) for outputs      | ttext       |                        |
 !  | type        | Type (so far: tracer or tag)                         | /           | tracer,tag             |
-!  | phase       | Phases list ("g"as / "l"iquid / "s"olid / "b"lowing) | /           | [g][l][s][b]           |
+!  | phase       | Phases list ("g"as / "l"iquid / "s"olid)             | /           | [g][l][s]              |
 !  | component   | Name(s) of the merged/cumulated section(s)           | /           | coma-separated names   |
 !  | iGeneration | Generation (>=1)                                     | /           |                        |
@@ -91 +91 @@
 !  | trac   | ntiso  | Isotopes + tagging tracers list + number         | / | ntraciso       |                 |
 !  | zone   | nzone  | Geographic tagging zones   list + number         | / | ntraceurs_zone |                 |
-!  | phase  | nphas  | Phases                     list + number         |                    |[g][l][s][b],1:4 |
+!  | phase  | nphas  | Phases                     list + number         |                    | [g][l][s], 1:3  |
 !  | iqIsoPha        | Index in "qx"           = f(name(1:ntiso)),phas) | iqiso              | 1:nqtot         |
 !  | itZonIso        | Index in "trac(1:ntiso)"= f(zone, name(1:niso))  | index_trac         | 1:ntiso         |
@@ -156 +156 @@
    INTEGER :: nqtrue                                                 !--- Tracers nb from tracer.def (no higher order moments)
    INTEGER :: iad                                                    !--- Advection scheme number
-   INTEGER :: ic, iq, jq, it, nt, im, nm, iz, k                      !--- Indexes and temporary variables
+   INTEGER :: iq, jq, nt, im, nm                                     !--- Indexes and temporary variables
    LOGICAL :: lerr, ll
-   CHARACTER(LEN=1) :: p
    TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:)
    TYPE(trac_type), POINTER             :: t1, t(:)
-   INTEGER :: ierr
    CHARACTER(LEN=maxlen),   ALLOCATABLE :: types_trac(:)  !--- Keyword for tracers type(s), parsed version
 
@@ -225 +223 @@
    ttp = type_trac; IF(fType /= 1) ttp = texp
 
-   IF(readTracersFiles(ttp, type_trac == 'repr'))     CALL abort_gcm(modname, 'problem with tracers file(s)',1)
+   IF(readTracersFiles(ttp, lRepr=type_trac=='repr')) CALL abort_gcm(modname, 'problem with tracers file(s)',1)
    !---------------------------------------------------------------------------------------------------------------------------
    IF(fType == 0) CALL abort_gcm(modname, 'Missing tracers file: "traceur.def", "tracer.def" or "tracer_<keyword>.def file.',1)
@@ -236 +234 @@
       nbtr = nqINCA + nqCO2                                          !--- Number of tracers passed to phytrac
       nqtrue = nbtr + nqo                                            !--- Total number of "true" tracers
-      IF(ALL([2,3,4,5] /= nqo)) CALL abort_gcm(modname, 'Only 2, 3, 4 , 5 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1)
+      IF(ALL([2,3] /= nqo)) CALL abort_gcm(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1)
       ALLOCATE(hadv(nqtrue), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA))
       ALLOCATE(vadv(nqtrue), vadv_inca(nqINCA),  pbl_flg_inca(nqINCA))
@@ -245 +243 @@
       ttr(1+nqo:nqCO2+nqo   )%component = 'co2i'
       ttr(1+nqo+nqCO2:nqtrue)%component = 'inca'
-      ttr(1+nqo      :nqtrue)%name      = [('CO2     ', k=1, nqCO2), solsym_inca]
+      ttr(1+nqo      :nqtrue)%name      = [('CO2     ', iq=1, nqCO2), solsym_inca]
       ttr(1+nqo+nqCO2:nqtrue)%parent    = tran0
       ttr(1+nqo+nqCO2:nqtrue)%phase     = 'g'
@@ -348 +346 @@
       IF(nm == 0) CYCLE                                              !--- No higher moments
       ttr(jq+1:jq+nm)             = t1
-      ttr(jq+1:jq+nm)%name        = [(TRIM(t1%name)    //'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%parent      = [(TRIM(t1%parent)  //'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%longName    = [(TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%iadv        = [(-iad,    im=1, nm) ]
-      ttr(jq+1:jq+nm)%isAdvected  = [(.FALSE., im=1, nm) ]
+      ttr(jq+1:jq+nm)%name        = [ (TRIM(t1%name)    //'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%parent      = [ (TRIM(t1%parent)  //'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%longName    = [ (TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%iadv        = [ (-iad,    im=1, nm) ]
+      ttr(jq+1:jq+nm)%isAdvected  = [ (.FALSE., im=1, nm) ]
       jq = jq + nm
    END DO
@@ -359 +357 @@
 
    !--- SET FIELDS %iqParent, %nqChildren, %iGeneration, %iqDescen, %nqDescen
-   CALL indexUpdate(tracers)
+   IF(indexUpdate(tracers)) CALL abort_gcm(modname, 'problem with tracers indices update', 1)
 
    !=== TEST ADVECTION SCHEME
@@ -384 +382 @@
    !=== READ PHYSICAL PARAMETERS FOR ISOTOPES ; DONE HERE BECAUSE dynetat0 AND iniacademic NEED "tnat" AND "alpha_ideal"
    niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE.
-   IF(readIsotopesFile()) CALL abort_gcm(modname, 'Problem when reading isotopes parameters', 1)
+   IF(processIsotopes()) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1)
 
    !--- Convection / boundary layer activation for all tracers
@@ -393 +391 @@
    nqtottr = nqtot - COUNT(delPhase(tracers%gen0Name) == 'H2O' .AND. tracers%component == 'lmdz')
    IF(COUNT(tracers%iso_iName == 0) - COUNT(delPhase(tracers%name) == 'H2O' .AND. tracers%component == 'lmdz') /= nqtottr) &
-      CALL abort_gcm(modname, 'pb dans le calcul de nqtottr', 1)
+      CALL abort_gcm(modname, 'problem with the computation of nqtottr', 1)
 
    !=== DISPLAY THE RESULTS
@@ -408 +406 @@
    t => tracers
    CALL msg('Information stored in infotrac :', modname)
-   IF(dispTable('isssssssssiiiiiiiii', &
-      ['iq    ', 'name  ', 'lName ', 'gen0N ', 'parent', 'type  ', 'phase ', 'compon', 'isPhy ', 'isAdv ', &
-       'iadv  ', 'iGen  ', 'iqPar ', 'nqDes ', 'nqChld', 'iGroup', 'iName ', 'iZone ', 'iPhase'],          &
+
+   IF(dispTable('isssssssssiiiiiiiii', ['iq  ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp',    &
+                'isPh', 'isAd', 'iadv', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'],   &
       cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, bool2str(t%isInPhysics), &
                                                                                   bool2str(t%isAdvected)), &

LMDZ6/branches/cirrus/libf/dyn3dmem/check_isotopes_loc.F90

@@ -24 +24 @@
                              iso_O17, iso_HTO
    LOGICAL, SAVE :: first=.TRUE.
+   LOGICAL, PARAMETER :: tnat1=.TRUE.
 !$OMP THREADPRIVATE(first)
 
@@ -37 +38 @@
       iso_O17 = strIdx(isoName,'H217O')
       iso_HTO = strIdx(isoName,'HTO')
-      IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1)
+      if (tnat1) then
+              tnat(:)=1.0
+      else
+         IF(getKey('tnat', tnat)) CALL abort_gcm(modname, 'missing isotopic parameter', 1)
+      endif
 !$OMP END MASTER
 !$OMP BARRIER

LMDZ6/branches/cirrus/libf/dyn3dmem/conf_gcm.F90

@@ -22 +22 @@
   USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
                        ok_guide, ok_limit, ok_strato, purmats, read_start, &
-                       ysinus, read_orop
+                       ysinus, read_orop, adv_qsat_liq
   USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
                        alphax,alphay,taux,tauy
@@ -660 +660 @@
      type_trac = 'lmdz'
      CALL getin('type_trac',type_trac)
+
+
+     !Config  Key  = adv_qsat_liq
+     !Config  Desc = option for qsat calculation in the dynamics
+     !Config  Def  = n 
+     !Config  Help = controls which phase is considered for qsat calculation 
+     !Config          
+     adv_qsat_liq = .FALSE.
+     CALL getin('adv_qsat_liq',adv_qsat_liq)
 
      !Config  Key  = ok_dynzon 
@@ -736 +745 @@
      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
      write(lunout,*)' ok_dyn_xios = ', ok_dyn_xios 
+     write(lunout,*)' adv_qsat_liq = ', adv_qsat_liq
   else
      !Config  Key  = clon

LMDZ6/branches/cirrus/libf/dyn3dmem/dynetat0_loc.F90

@@ -42 +42 @@
   INTEGER, PARAMETER :: length=100
   INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase, ix
-  REAL    :: time, tnat, alpha_ideal, tab_cntrl(length)    !--- RUN PARAMS TABLE
+  REAL    :: time,tab_cntrl(length)    !--- RUN PARAMS TABLE
+  REAL    :: tnat, alpha_ideal
   REAL,             ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:),   ps_glo(:)
   REAL,             ALLOCATABLE :: ucov_glo(:,:),    q_glo(:,:), phis_glo(:)
   REAL,             ALLOCATABLE :: teta_glo(:,:)
   LOGICAL :: lSkip, ll
+  LOGICAL,PARAMETER :: tnat1=.TRUE.
 !-------------------------------------------------------------------------------
   modname="dynetat0_loc"
@@ -179 +181 @@
       iqParent = tracers(iq)%iqParent
       IF(tracers(iq)%iso_iZone == 0) THEN
-         IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
+         if (tnat1) then
+                 tnat=1.0
+                 alpha_ideal=1.0
+                 write(*,*) 'attention dans dynetat0: les alpha_ideal sont a 1'
+         else
+          IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
             CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1)
+         endif
          CALL msg('Tracer <'//TRIM(var)//'> is missing => initialized with a simplified Rayleigh distillation law.', modname)
          q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
@@ -193 +201 @@
          ! remplacant 1 par izone_init dans la ligne qui suit.
          IF(tracers(iq)%iso_iZone == 1) THEN
-          q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
+           q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
          ELSE
            q(ijb_u:ije_u,:,iq) =  0.

LMDZ6/branches/cirrus/libf/dyn3dmem/dynredem_mod.F90

@@ -7 +7 @@
   PRIVATE
   PUBLIC :: dynredem_write_u, dynredem_write_v, dynredem_read_u, err
-  PUBLIC :: cre_var, get_var1, put_var, fil, modname, msg
+  PUBLIC :: cre_var, put_var, fil, modname, msg
   CHARACTER(LEN=256), SAVE :: fil, modname
   INTEGER,            SAVE :: nvarid

LMDZ6/branches/cirrus/libf/dyn3dmem/gcm.F90

@@ -480 +480 @@
   !$OMP COPYIN(saison,ecripar,fxyhypb,ysinus,read_start,ok_guide) &
   !$OMP COPYIN(ok_strato,ok_gradsfile,ok_limit,ok_etat0) &
-  !$OMP COPYIN(iflag_phys,iflag_trac)
+  !$OMP COPYIN(iflag_phys,iflag_trac,adv_qsat_liq)
   CALL leapfrog_loc(ucov,vcov,teta,ps,masse,phis,q,time_0)
   !$OMP END PARALLEL

LMDZ6/branches/cirrus/libf/dyn3dmem/iniacademic_loc.F90

@@ -85 +85 @@
 
   REAL zdtvr, tnat, alpha_ideal
+  LOGICAL,PARAMETER :: tnat1=.true.
   
   character(len=*),parameter :: modname="iniacademic"
@@ -323 +324 @@
               iqParent = tracers(iq)%iqParent
               IF(tracers(iq)%iso_iZone == 0) THEN
-                 IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
+                 if (tnat1) then
+                         tnat=1.0
+                         alpha_ideal=1.0
+                         write(*,*) 'Attention dans iniacademic: alpha_ideal=1'
+                 else
+                    IF(getKey('tnat', tnat, isoName(iName)) .OR. getKey('alpha', alpha_ideal, isoName(iName))) &
                     CALL abort_gcm(TRIM(modname), 'missing isotopic parameters', 1)
+                 endif
                  q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-              ELSE
-                 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
-              END IF
+              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
+                 IF(tracers(iq)%iso_iZone == 1) THEN ! a verifier.
+                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
+                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
+                    q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
+                 else !IF(tracers(iq)%iso_iZone == 1) THEN
+                    q(ijb_u:ije_u,:,iq) = 0.0
+                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
+              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
            enddo
         else

LMDZ6/branches/cirrus/libf/dyn3dmem/logic_mod.F90

@@ -30 +30 @@
   LOGICAL hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
                  ! (only used if disvert_type==2)
+  LOGICAL adv_qsat_liq ! true if qsat is calculated alwats wrt liquid for
+                       ! adapted Van Leer advection scheme
   INTEGER iflag_phys ! type of physics to call: 0 none, 1: phy*** package,
                      ! 2: Held & Suarez, 101-200: aquaplanets & terraplanets
@@ -37 +39 @@
 !$OMP     apdiss,apdelq,saison,ecripar,fxyhypb,ysinus, &
 !$OMP     read_start,ok_guide,ok_strato,ok_gradsfile, &
-!$OMP     ok_limit,ok_etat0,hybrid)
+!$OMP     ok_limit,ok_etat0,hybrid, adv_qsat_liq)
 !$OMP THREADPRIVATE(iflag_phys,iflag_trac)
 

LMDZ6/branches/cirrus/libf/dyn3dmem/qminimum_loc.F

@@ -31 +31 @@
 c     .................................................................
 c
+cDC iq_val and iq_liq are usable for q only, NOT for q_follow
+c   and zx_defau_diag (crash if iq_val/liq==3) => vapor/liquid
+c   water at hardcoded indices 1/2 in these variables
       INTEGER i, k, iq
       REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
@@ -49 +52 @@
       INTEGER ixt
       INTEGER iso_verif_noNaN_nostop
-c
-c Quand l'eau liquide est trop petite (ou negative), on prend
-c l'eau vapeur de la meme couche et la convertit en eau liquide
-c (sans changer la temperature !)
-c
 
 c$OMP BARRIER
@@ -63 +61 @@
          first = .FALSE.
       END IF
+c
+c Quand l'eau liquide est trop petite (ou negative), on prend
+c l'eau vapeur de la meme couche et la convertit en eau liquide
+c (sans changer la temperature !)
+c
+
       call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
 
@@ -73 +77 @@
           zx_defau_diag(i,k,1)=0.0
           zx_defau_diag(i,k,2)=0.0
-          q_follow(i,k,1)=q(i,k,1)
-          q_follow(i,k,2)=q(i,k,2)
+          q_follow(i,k,1)=q(i,k,iq_vap)
+          q_follow(i,k,2)=q(i,k,iq_liq)
         ENDDO
 c$OMP END DO NOWAIT
@@ -80 +84 @@
 
       !write(lunout,*) 'qminimum 57'
-      DO 1000 k = 1, llm
+      DO k = 1, llm
 c$OMP DO SCHEDULE(STATIC)       
-      DO 1040 i = ijb, ije
-            if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
-
-              if (niso > 0) zx_defau_diag(i,k,iq_liq)=AMAX1
+        DO i = ijb, ije
+          if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
+
+            if (niso > 0) zx_defau_diag(i,k,2)=AMAX1
      :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
 
-               q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
-               q(i,k,iq_liq) = seuil_liq
-            endif
- 1040 CONTINUE
-c$OMP END DO NOWAIT
- 1000 CONTINUE
+            q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
+            q(i,k,iq_liq) = seuil_liq
+          endif
+        END DO
+c$OMP END DO NOWAIT
+      END DO
 
 c
@@ -100 +104 @@
 c
       !write(lunout,*) 'qminimum 81'
-      iq = iq_vap
-c
       DO k = llm, 2, -1
 ccc      zx_abc = dpres(k) / dpres(k-1)
 c$OMP DO SCHEDULE(STATIC)
-      DO i = ijb, ije
-
-         if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
-
-            if (niso > 0)
-     &        zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
-
-            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
-     &           deltap(i,k) / deltap(i,k-1)
-            q(i,k,iq)   =  seuil_vap  
-
-         endif
-      ENDDO
+        DO i = ijb, ije
+
+          if ( seuil_vap - q(i,k,iq_vap) .gt. 0.d0 ) then
+
+            if (niso > 0) zx_defau_diag(i,k,1)
+     &           = AMAX1( seuil_vap - q(i,k,iq_vap), 0.0 )
+
+            q(i,k-1,iq_vap) = q(i,k-1,iq_vap) - (seuil_vap
+     &           -q(i,k,iq_vap)) * deltap(i,k)/deltap(i,k-1)
+            q(i,k,iq_vap)   =  seuil_vap  
+
+          endif
+        ENDDO
 c$OMP END DO NOWAIT
       ENDDO
@@ -129 +131 @@
 c$OMP DO SCHEDULE(STATIC)
       DO i = ijb, ije
-         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
-         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq_vap) )
+         q(i,1,iq_vap)  = AMAX1( q(i,1,iq_vap), seuil_vap )
          IF (zx_pump(i) > 0.0) THEN
             nb_pump = nb_pump+1
@@ -165 +167 @@
       DO i = ijb, ije
         if (zx_pump(i).gt.0.0) then
-          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
+          q_follow(i,1,1)=q_follow(i,1,1)+zx_pump(i)
         endif !if (zx_pump(i).gt.0.0) then
       enddo !DO i = ijb, ije  
@@ -175 +177 @@
 c$OMP DO SCHEDULE(STATIC)      
         DO i = ijb, ije
-          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
+          if (zx_defau_diag(i,k,1).gt.0.0) then             
               ! on ajoute la vapeur en k     
-!              write(lunout,*) 'i,k,q_follow(i,k-1,iq_vap)=',
-!     :                 i,k,q_follow(i,k-1,iq_vap)          
-              if (q_follow(i,k-1,iq_vap).lt.min_qParent) then
+!              write(lunout,*) 'i,k,q_follow(i,k-1,ivap)=',
+!     :                 i,k,q_follow(i,k-1,1)          
+              if (q_follow(i,k-1,1).lt.min_qParent) then
                 write(lunout,*) 'tmp qmin: on stoppe'
                 write(lunout,*) 'zx_pump(i)=',zx_pump(i)
-                write(lunout,*) 'q_follow(i,:,iq_vap)=',
-     :                   q_follow(i,:,iq_vap)
+                write(lunout,*) 'q_follow(i,:,ivap)=',
+     :                   q_follow(i,:,1)
                 write(lunout,*) 'k=',k
                 call abort_gcm("qminimum","not enough vapor",1)
@@ -189 +191 @@
             do ixt=1,ntiso
 !                write(lunout,*) 'qmin 168: ixt=',ixt
-!                write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap)=',
+!                write(lunout,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
 !     :             q(i,k,iqIsoPha(ixt,iq_vap))
-!                write(lunout,*) 'zx_defau_diag(i,k,iq_vap)=',
-!     :                  zx_defau_diag(i,k,iq_vap)
-!                write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap)=',
+!                write(lunout,*) 'zx_defau_diag(i,k,ivap)=',
+!     :                  zx_defau_diag(i,k,1)
+!                write(lunout,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
 !     :                   q(i,k-1,iqIsoPha(ixt,iq_vap))     
 
                q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :           +zx_defau_diag(i,k,iq_vap)
-     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
+     :           +zx_defau_diag(i,k,1)
+     :           *q(i,k-1,iqIsoPha(ixt,iq_vap))/q_follow(i,k-1,1)
                 
               if (isoCheck) then
@@ -204 +206 @@
      :                   'qminimum 155').eq.1) then
                    write(*,*) 'i,k,ixt=',i,k,ixt
-                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
-     :                   q_follow(i,k-1,iq_vap)
+                   write(*,*) 'q_follow(i,k-1,ivap)=',
+     :                   q_follow(i,k-1,1)
                    write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
      :                   q(i,k,iqIsoPha(ixt,iq_vap))
-                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
-     :                   zx_defau_diag(i,k,iq_vap)
+                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
+     :                   zx_defau_diag(i,k,1)
                    write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
      :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
@@ -219 +221 @@
                q(i,k-1,iqIsoPha(ixt,iq_vap)) =
      :            q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,iq_vap)
+     :              -zx_defau_diag(i,k,1)
      :              *deltap(i,k)/deltap(i,k-1)
      :              *q(i,k-1,iqIsoPha(ixt,iq_vap))
-     :              /q_follow(i,k-1,iq_vap)
+     :              /q_follow(i,k-1,1)
 
                if (isoCheck) then
@@ -229 +231 @@
      :                   'qminimum 175').eq.1) then
                    write(*,*) 'k,i,ixt=',k,i,ixt
-                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
-     :                   q_follow(i,k-1,iq_vap)
+                   write(*,*) 'q_follow(i,k-1,ivap)=',
+     :                   q_follow(i,k-1,1)
                    write(*,*) 'q(i,k,iqIsoPha(ixt,iq_vap))=',
      :                   q(i,k,iqIsoPha(ixt,iq_vap))
-                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
-     :                   zx_defau_diag(i,k,iq_vap)
+                   write(*,*) 'zx_defau_diag(i,k,ivap)=',
+     :                   zx_defau_diag(i,k,1)
                    write(*,*) 'q(i,k-1,iqIsoPha(ixt,iq_vap))=',
      :                   q(i,k-1,iqIsoPha(ixt,iq_vap))
@@ -242 +244 @@
 
               enddo !do ixt=1,niso
-              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
-     :               +zx_defau_diag(i,k,iq_vap)
-              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
-     :               -zx_defau_diag(i,k,iq_vap)
+              q_follow(i,k,1)=   q_follow(i,k,1)
+     :               +zx_defau_diag(i,k,1)
+              q_follow(i,k-1,1)=   q_follow(i,k-1,1)
+     :               -zx_defau_diag(i,k,1)
      :              *deltap(i,k)/deltap(i,k-1)
-          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
         enddo !DO i = 1, ip1jmp1        
 c$OMP END DO NOWAIT
@@ -260 +262 @@
 c$OMP DO SCHEDULE(STATIC)
         DO i = ijb, ije
-          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
+          if (zx_defau_diag(i,k,2).gt.0.0) then
 
               ! on ajoute eau liquide en k en k              
               do ixt=1,ntiso
                q(i,k,iqIsoPha(ixt,iq_liq))=q(i,k,iqIsoPha(ixt,iq_liq))
-     :              +zx_defau_diag(i,k,iq_liq)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,iq_vap)
+     :              +zx_defau_diag(i,k,2)
+     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)
               ! et on la retranche à la vapeur en k
                q(i,k,iqIsoPha(ixt,iq_vap))=q(i,k,iqIsoPha(ixt,iq_vap))
-     :              -zx_defau_diag(i,k,iq_liq)
-     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,iq_vap)   
+     :              -zx_defau_diag(i,k,2)
+     :              *q(i,k,iqIsoPha(ixt,iq_vap))/q_follow(i,k,1)   
               enddo !do ixt=1,niso
-              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
-     :               +zx_defau_diag(i,k,iq_liq)
-              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
-     :               -zx_defau_diag(i,k,iq_liq)
-          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
+              q_follow(i,k,2)=   q_follow(i,k,2)
+     :               +zx_defau_diag(i,k,2)
+              q_follow(i,k,1)=   q_follow(i,k,1)
+     :               -zx_defau_diag(i,k,2)
+          endif !if (zx_defau_diag(i,k,1).gt.0.0) then
         enddo !DO i = ijb, ije
 c$OMP END DO NOWAIT       

LMDZ6/branches/cirrus/libf/dyn3dmem/vlspltgen_loc.F

@@ -10 +10 @@
 c
 c    ********************************************************************
-c          Shema  d'advection " pseudo amont " .
+c          Schema  d'advection " pseudo amont " .
 c      + test sur humidite specifique: Q advecte< Qsat aval
 c                   (F. Codron, 10/99)
@@ -32 +32 @@
       USE vlspltgen_mod
       USE comconst_mod, ONLY: cpp
+      USE logic_mod, ONLY: adv_qsat_liq
       IMPLICIT NONE
 
@@ -108 +109 @@
          ENDDO
          DO ij = ijb, ije
-          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          IF (adv_qsat_liq) THEN
+             zdelta = 0.
+          ELSE
+             zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          ENDIF
           play   = 0.5*(p(ij,l)+p(ij,l+1))
           qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )

LMDZ6/branches/cirrus/libf/dyn3dmem/vlspltqs_loc.F

@@ -806 +806 @@
          IF (pole_sud) THEN
          
-           convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),iq,1)/apols
+           convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),1)/apols
            convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
            DO ij = ip1jm+1,ip1jmp1

LMDZ6/branches/cirrus/libf/misc/readTracFiles_mod.f90

@@ -1 +1 @@
 MODULE readTracFiles_mod
 
-  USE strings_mod,    ONLY: msg, find, get_in, str2int, dispTable, strHead,  strReduce,  strFind, strStack, strIdx, &
-       test, removeComment, cat, fmsg, maxlen, int2str, checkList, strParse, strReplace, strTail, strCount, reduceExpr
+  USE strings_mod,    ONLY: msg, find, get_in, dispTable, strHead,  strReduce,  strFind, strStack, strIdx, &
+             removeComment, cat, fmsg, maxlen, checkList, strParse, strReplace, strTail, strCount, reduceExpr, &
+             int2str, str2int, real2str, str2real, bool2str, str2bool
 
   IMPLICIT NONE
@@ -9 +10 @@
 
   PUBLIC :: maxlen                                              !--- PARAMETER FOR CASUAL STRING LENGTH
-  PUBLIC :: tracers                                             !--- TRACERS  DESCRIPTION DATABASE
-  PUBLIC :: trac_type, setGeneration, indexUpdate               !--- TRACERS  DESCRIPTION ASSOCIATED TOOLS
+  PUBLIC :: trac_type, tracers, setGeneration, indexUpdate      !--- TRACERS  DESCRIPTION DATABASE + ASSOCIATED TOOLS
   PUBLIC :: testTracersFiles, readTracersFiles                  !--- TRACERS FILES READING ROUTINES
-  PUBLIC :: getKey, fGetKey, fGetKeys, addKey, setDirectKeys    !--- TOOLS TO GET/SET KEYS FROM/TO  tracers & isotopes
-  PUBLIC :: getKeysDBase,    setKeysDBase                       !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes)
-
-  PUBLIC :: addPhase, getiPhase,  old_phases, phases_sep, &     !--- FUNCTIONS RELATED TO THE PHASES
-   nphases, delPhase, getPhase, known_phases, phases_names      !--- + ASSOCIATED VARIABLES
+  PUBLIC :: getKeysDBase, setKeysDBase                          !--- TOOLS TO GET/SET THE DATABASE (tracers & isotopes)
+  PUBLIC :: addTracer, delTracer                                !--- ADD/REMOVE A TRACER FROM
+  PUBLIC :: addKey,    delKey,    getKey,    keys_type          !--- TOOLS TO SET/DEL/GET KEYS FROM/TO  tracers & isotopes
+  PUBLIC :: addPhase,  delPhase,  getPhase,  getiPhase,  &      !--- FUNCTIONS RELATED TO THE PHASES
+   nphases, old_phases, phases_sep, known_phases, phases_names  !--- + ASSOCIATED VARIABLES
 
   PUBLIC :: oldH2OIso, newH2OIso, old2newH2O, new2oldH2O        !--- H2O ISOTOPES BACKWARD COMPATIBILITY (OLD traceur.def)
   PUBLIC :: oldHNO3,   newHNO3                                  !--- HNO3 REPRO   BACKWARD COMPATIBILITY (OLD start.nc)
 
-  PUBLIC :: tran0, idxAncestor, ancestor                        !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS
+  PUBLIC :: tran0                                               !--- TRANSPORTING FLUID (USUALLY air)
 
   !=== FOR ISOTOPES: GENERAL
-  PUBLIC :: isot_type, readIsotopesFile, isoSelect              !--- ISOTOPES DESCRIPTION TYPE + READING ROUTINE
-  PUBLIC :: ixIso, nbIso                                        !--- INDEX OF SELECTED ISOTOPES CLASS + NUMBER OF CLASSES
+  PUBLIC :: isot_type, processIsotopes, isoSelect, ixIso, nbIso !--- PROCESS [AND READ] & SELECT ISOTOPES + CLASS IDX & NUMBER
 
   !=== FOR ISOTOPES: H2O FAMILY ONLY
@@ -36 +35 @@
   PUBLIC :: itZonIso                                            !--- Idx IN isoName(1:niso) = f(tagging idx, isotope idx)
   PUBLIC :: iqIsoPha                                            !--- Idx IN qx(1:nqtot)     = f(isotope idx,   phase idx)
+  PUBLIC :: iqWIsoPha                                           !--- Idx IN qx(1:nqtot)     = f(isotope idx,   phase idx) but with normal water first
   PUBLIC :: isoCheck                                            !--- FLAG TO RUN ISOTOPES CHECKING ROUTINES
 
   PUBLIC :: maxTableWidth
 !------------------------------------------------------------------------------------------------------------------------------
-  TYPE :: keys_type                                        !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT
-    CHARACTER(LEN=maxlen)              :: name             !--- Tracer name
-    CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:)           !--- Keys string list
-    CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)           !--- Corresponding values string list
+  TYPE :: keys_type                                             !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT
+    CHARACTER(LEN=maxlen)              :: name                  !--- Tracer name
+    CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:)                !--- Keys string list
+    CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)                !--- Corresponding values string list
   END TYPE keys_type
 !------------------------------------------------------------------------------------------------------------------------------
-  TYPE :: trac_type                                        !=== TYPE FOR A SINGLE TRACER NAMED "name"
-    CHARACTER(LEN=maxlen) :: name        = ''              !--- Name of the tracer
-    CHARACTER(LEN=maxlen) :: gen0Name    = ''              !--- First generation ancestor name
-    CHARACTER(LEN=maxlen) :: parent      = ''              !--- Parent name
-    CHARACTER(LEN=maxlen) :: longName    = ''              !--- Long name (with advection scheme suffix)
-    CHARACTER(LEN=maxlen) :: type        = 'tracer'        !--- Type  (so far: 'tracer' / 'tag')
-    CHARACTER(LEN=maxlen) :: phase       = 'g'             !--- Phase ('g'as / 'l'iquid / 's'olid)
-    CHARACTER(LEN=maxlen) :: component   = ''              !--- Coma-separated list of components (Ex: lmdz,inca)
-    INTEGER               :: iGeneration = -1              !--- Generation number (>=0)
-    INTEGER               :: iqParent    = 0               !--- Parent index
-    INTEGER,  ALLOCATABLE :: iqDescen(:)                   !--- Descendants index (in growing generation order)
-    INTEGER               :: nqDescen    = 0               !--- Number of descendants (all generations)
-    INTEGER               :: nqChildren  = 0               !--- Number of children  (first generation)
-    TYPE(keys_type)       :: keys                          !--- <key>=<val> pairs vector
-    INTEGER               :: iadv        = 10              !--- Advection scheme used
-    LOGICAL               :: isAdvected  = .FALSE.         !--- "true" tracers: iadv > 0.   COUNT(isAdvected )=nqtrue
-    LOGICAL               :: isInPhysics = .TRUE.          !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr
-    INTEGER               :: iso_iGroup  = 0               !--- Isotopes group index in isotopes(:)
-    INTEGER               :: iso_iName   = 0               !--- Isotope  name  index in isotopes(iso_iGroup)%trac(:)
-    INTEGER               :: iso_iZone   = 0               !--- Isotope  zone  index in isotopes(iso_iGroup)%zone(:)
-    INTEGER               :: iso_iPhase  = 0               !--- Isotope  phase index in isotopes(iso_iGroup)%phase
+  TYPE :: trac_type                                             !=== TYPE FOR A SINGLE TRACER NAMED "name"
+    CHARACTER(LEN=maxlen) :: name        = ''                   !--- Name of the tracer
+    TYPE(keys_type)       :: keys                               !--- <key>=<val> pairs vector
+    CHARACTER(LEN=maxlen) :: gen0Name    = ''                   !--- First generation ancestor name
+    CHARACTER(LEN=maxlen) :: parent      = ''                   !--- Parent name
+    CHARACTER(LEN=maxlen) :: longName    = ''                   !--- Long name (with advection scheme suffix)
+    CHARACTER(LEN=maxlen) :: type        = 'tracer'             !--- Type  (so far: 'tracer' / 'tag')
+    CHARACTER(LEN=maxlen) :: phase       = 'g'                  !--- Phase ('g'as / 'l'iquid / 's'olid)
+    CHARACTER(LEN=maxlen) :: component   = ''                   !--- Coma-separated list of components (Ex: lmdz,inca)
+    INTEGER               :: iGeneration = -1                   !--- Generation number (>=0)
+    INTEGER               :: iqParent    = 0                    !--- Parent index
+    INTEGER,  ALLOCATABLE :: iqDescen(:)                        !--- Descendants index (in growing generation order)
+    INTEGER               :: nqDescen    = 0                    !--- Number of descendants (all generations)
+    INTEGER               :: nqChildren  = 0                    !--- Number of children  (first generation)
+    INTEGER               :: iadv        = 10                   !--- Advection scheme used
+    LOGICAL               :: isAdvected  = .FALSE.              !--- "true" tracers: iadv > 0.   COUNT(isAdvected )=nqtrue
+    LOGICAL               :: isInPhysics = .TRUE.               !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr
+    INTEGER               :: iso_iGroup  = 0                    !--- Isotopes group index in isotopes(:)
+    INTEGER               :: iso_iName   = 0                    !--- Isotope  name  index in isotopes(iso_iGroup)%trac(:)
+    INTEGER               :: iso_iZone   = 0                    !--- Isotope  zone  index in isotopes(iso_iGroup)%zone(:)
+    INTEGER               :: iso_iPhase  = 0                    !--- Isotope  phase index in isotopes(iso_iGroup)%phase
   END TYPE trac_type
 !------------------------------------------------------------------------------------------------------------------------------
-  TYPE :: isot_type                                        !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent"
-    CHARACTER(LEN=maxlen)              :: parent           !--- Isotopes family name (parent tracer name ; ex: H2O)
-    LOGICAL                            :: check=.FALSE.    !--- Triggering of the checking routines
-    TYPE(keys_type),       ALLOCATABLE :: keys(:)          !--- Isotopes keys/values pairs list     (length: niso)
-    CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:)          !--- Isotopes + tagging tracers list     (length: ntiso)
-    CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:)          !--- Geographic tagging zones names list (length: nzone)
-    CHARACTER(LEN=maxlen)              :: phase = 'g'      !--- Phases list: [g][l][s]              (length: nphas)
-    INTEGER                            :: niso  = 0        !--- Number of isotopes, excluding tagging tracers
-    INTEGER                            :: nzone = 0        !--- Number of geographic tagging zones
-    INTEGER                            :: ntiso = 0        !--- Number of isotopes, including tagging tracers
-    INTEGER                            :: nphas = 0        !--- Number phases
-    INTEGER,               ALLOCATABLE :: iqIsoPha(:,:)    !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso)),phas)
-                                                           !---        "iqIsoPha" former name: "iqiso"
-    INTEGER,               ALLOCATABLE :: itZonIso(:,:)    !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso))
-                                                           !---        "itZonIso" former name: "index_trac"
-  END TYPE isot_type
+  TYPE :: isot_type                                             !=== TYPE FOR AN ISOTOPES FAMILY DESCENDING ON TRACER "parent"
+    CHARACTER(LEN=maxlen)              :: parent                !--- Isotopes family name (parent tracer name ; ex: H2O)
+    TYPE(keys_type),       ALLOCATABLE :: keys(:)               !--- Isotopes keys/values pairs list     (length: niso)
+    LOGICAL                            :: check=.FALSE.         !--- Flag for checking routines triggering
+    CHARACTER(LEN=maxlen), ALLOCATABLE :: trac(:)               !--- Isotopes + tagging tracers list     (length: ntiso)
+    CHARACTER(LEN=maxlen), ALLOCATABLE :: zone(:)               !--- Geographic tagging zones names list (length: nzone)
+    CHARACTER(LEN=maxlen)              :: phase = 'g'           !--- Phases list: [g][l][s]              (length: nphas)
+    INTEGER                            :: niso  = 0             !--- Number of isotopes, excluding tagging tracers
+    INTEGER                            :: ntiso = 0             !--- Number of isotopes, including tagging tracers
+    INTEGER                            :: nzone = 0             !--- Number of geographic tagging zones
+    INTEGER                            :: nphas = 0             !--- Number of phases
+    INTEGER,               ALLOCATABLE :: iqIsoPha(:,:)         !--- Idx in "tracers(1:nqtot)" = f(name(1:ntiso),phas)
+                                                                !---        (former name: "iqiso"
+    INTEGER,               ALLOCATABLE :: iqWIsoPha(:,:)        !--- Idx in "tracers(1:nqtot)" = f([H2O,name(1:ntiso)],phas)
+    INTEGER,               ALLOCATABLE :: itZonIso(:,:)         !--- Idx in "trac(1:ntiso)" = f(zone, name(1:niso))
+  END TYPE isot_type                                            !---        (former name: "index_trac")
 !------------------------------------------------------------------------------------------------------------------------------
   TYPE :: dataBase_type                                         !=== TYPE FOR TRACERS SECTION
-    CHARACTER(LEN=maxlen)  :: name                              !--- Section name
+    CHARACTER(LEN=maxlen) :: name                               !--- Section name
     TYPE(trac_type), ALLOCATABLE :: trac(:)                     !--- Tracers descriptors
   END TYPE dataBase_type
 !------------------------------------------------------------------------------------------------------------------------------
   INTERFACE getKey
-    MODULE PROCEDURE getKeyByName_s1, getKeyByName_s1m, getKeyByName_sm, getKey_sm, &
-                     getKeyByName_i1, getKeyByName_i1m, getKeyByName_im, getKey_im, &
-                     getKeyByName_r1, getKeyByName_r1m, getKeyByName_rm, getKey_rm, &
-                     getKeyByName_l1, getKeyByName_l1m, getKeyByName_lm, getKey_lm
+    MODULE PROCEDURE &
+       getKeyByIndex_s111, getKeyByIndex_sm11, getKeyByIndex_s1m1, getKeyByIndex_smm1, getKeyByIndex_s1mm, getKeyByIndex_smmm, &
+       getKeyByIndex_i111, getKeyByIndex_im11, getKeyByIndex_i1m1, getKeyByIndex_imm1, getKeyByIndex_i1mm, getKeyByIndex_immm, &
+       getKeyByIndex_r111, getKeyByIndex_rm11, getKeyByIndex_r1m1, getKeyByIndex_rmm1, getKeyByIndex_r1mm, getKeyByIndex_rmmm, &
+       getKeyByIndex_l111, getKeyByIndex_lm11, getKeyByIndex_l1m1, getKeyByIndex_lmm1, getKeyByIndex_l1mm, getKeyByIndex_lmmm, &
+        getKeyByName_s111,  getKeyByName_sm11,  getKeyByName_s1m1,  getKeyByName_smm1,  getKeyByName_s1mm,  getKeyByName_smmm, &
+        getKeyByName_i111,  getKeyByName_im11,  getKeyByName_i1m1,  getKeyByName_imm1,  getKeyByName_i1mm,  getKeyByName_immm, &
+        getKeyByName_r111,  getKeyByName_rm11,  getKeyByName_r1m1,  getKeyByName_rmm1,  getKeyByName_r1mm,  getKeyByName_rmmm, &
+        getKeyByName_l111,  getKeyByName_lm11,  getKeyByName_l1m1,  getKeyByName_lmm1,  getKeyByName_l1mm,  getKeyByName_lmmm
   END INTERFACE getKey
 !------------------------------------------------------------------------------------------------------------------------------
-  INTERFACE    isoSelect;  MODULE PROCEDURE  isoSelectByIndex,  isoSelectByName; END INTERFACE isoSelect
-  INTERFACE  old2newH2O;   MODULE PROCEDURE  old2newH2O_1,  old2newH2O_m;        END INTERFACE old2newH2O
-  INTERFACE  new2oldH2O;   MODULE PROCEDURE  new2oldH2O_1,  new2oldH2O_m;        END INTERFACE new2oldH2O
-  INTERFACE fGetKey;       MODULE PROCEDURE fgetKeyIdx_s1, fgetKeyNam_s1;        END INTERFACE fGetKey
-  INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx, trSubset_Name, trSubset_gen0Name; END INTERFACE tracersSubset
-  INTERFACE idxAncestor;   MODULE PROCEDURE idxAncestor_1, idxAncestor_m, idxAncestor_mt;    END INTERFACE idxAncestor
-  INTERFACE    ancestor;   MODULE PROCEDURE    ancestor_1,    ancestor_m,    ancestor_mt;    END INTERFACE    ancestor
-  INTERFACE      addKey;   MODULE PROCEDURE      addKey_1; END INTERFACE addKey!,      addKey_m,     addKey_mm;     END INTERFACE addKey
-  INTERFACE    addPhase;   MODULE PROCEDURE   addPhase_s1,   addPhase_sm,   addPhase_i1,   addPhase_im; END INTERFACE addPhase
+  INTERFACE addKey
+    MODULE PROCEDURE addKey_s11, addKey_s1m, addKey_smm, addKey_i11, addKey_i1m, addKey_imm, &
+                     addKey_r11, addKey_r1m, addKey_rmm, addKey_l11, addKey_l1m, addKey_lmm
+  END INTERFACE addKey
+!------------------------------------------------------------------------------------------------------------------------------
+  INTERFACE     isoSelect; MODULE PROCEDURE  isoSelectByIndex,  isoSelectByName; END INTERFACE isoSelect
+  INTERFACE    old2newH2O; MODULE PROCEDURE  old2newH2O_1,  old2newH2O_m;        END INTERFACE old2newH2O
+  INTERFACE    new2oldH2O; MODULE PROCEDURE  new2oldH2O_1,  new2oldH2O_m;        END INTERFACE new2oldH2O
+  INTERFACE     addTracer; MODULE PROCEDURE   addTracer_1, addTracer_1def;       END INTERFACE addTracer
+  INTERFACE     delTracer; MODULE PROCEDURE   delTracer_1, delTracer_1def;       END INTERFACE delTracer
+  INTERFACE      addPhase; MODULE PROCEDURE   addPhase_s1,  addPhase_sm,  addPhase_i1,  addPhase_im; END INTERFACE addPhase
+  INTERFACE tracersSubset; MODULE PROCEDURE trSubset_Indx,     trSubset_Name,     trSubset_gen0Name; END INTERFACE tracersSubset
 !------------------------------------------------------------------------------------------------------------------------------
 
@@ -114 +122 @@
   !--- SOME PARAMETERS THAT ARE NOT LIKELY TO CHANGE OFTEN
   CHARACTER(LEN=maxlen), SAVE      :: tran0        = 'air'      !--- Default transporting fluid
-  CHARACTER(LEN=maxlen), PARAMETER :: old_phases   = 'vlifbc'     !--- Old phases for water (no separator)
-  CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsfbc'     !--- Known phases initials
+  CHARACTER(LEN=maxlen), PARAMETER :: old_phases   = 'vlirb'    !--- Old phases for water (no separator)
+  CHARACTER(LEN=maxlen), PARAMETER :: known_phases = 'glsrb'    !--- Known phases initials
   INTEGER, PARAMETER :: nphases = LEN_TRIM(known_phases)        !--- Number of phases
   CHARACTER(LEN=maxlen), SAVE      :: phases_names(nphases) &   !--- Known phases names
-                                = ['gaseous', 'liquid ', 'solid  ', 'fracld ', 'blosnow', 'cldvapr']
-  CHARACTER(LEN=1), SAVE :: phases_sep  =  '_'                  !--- Phase separator
-  LOGICAL,          SAVE :: tracs_merge = .TRUE.                !--- Merge/stack tracers lists
-  LOGICAL,          SAVE :: lSortByGen  = .TRUE.                !--- Sort by growing generation
+                                = ['gaseous  ', 'liquid   ', 'solid    ', 'cloud    ','blownSnow']
+  CHARACTER(LEN=1),      SAVE :: phases_sep  =  '_'             !--- Phase separator
   CHARACTER(LEN=maxlen), SAVE :: isoFile = 'isotopes_params.def'!--- Name of the isotopes parameters file
 
@@ -128 +134 @@
   CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H216O', 'HDO  ', 'H218O', 'H217O', 'HTO  ']
 
-  !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES
+  !--- CORRESPONDANCE BETWEEN OLD AND NEW HNO3 RELATED SPECIES NAMES (FOR REPROBUS)
   CHARACTER(LEN=maxlen), SAVE ::   oldHNO3(2) = ['HNO3_g ', 'HNO3   ']
   CHARACTER(LEN=maxlen), SAVE ::   newHNO3(2) = ['HNO3   ', 'HNO3tot']
@@ -138 +144 @@
   !=== ALIASES OF VARIABLES FROM SELECTED ISOTOPES FAMILY EMBEDDED IN "isotope" (isotopes(ixIso))
   TYPE(isot_type),         SAVE, POINTER :: isotope             !--- CURRENTLY SELECTED ISOTOPES FAMILY DESCRIPTOR
-  INTEGER,                 SAVE          :: ixIso, iH2O         !--- Index of the selected isotopes family and H2O family
+  INTEGER,                 SAVE          :: ixIso, iH2O=0       !--- Index of the selected isotopes family and H2O family
   INTEGER,                 SAVE          :: nbIso               !--- Number of isotopes classes
   LOGICAL,                 SAVE          :: isoCheck            !--- Flag to trigger the checking routines
@@ -148 +154 @@
                                             nphas, ntiso        !--- NUMBER OF PHASES AND ISOTOPES + ISOTOPIC TAGGING TRACERS
   INTEGER,                 SAVE, POINTER ::itZonIso(:,:), &     !--- INDEX IN "isoTrac" AS f(tagging zone idx,  isotope idx)
-                                           iqIsoPha(:,:)        !--- INDEX IN "qx"      AS f(isotopic tracer idx, phase idx)
+                                           iqIsoPha(:,:), &     !--- INDEX IN "qx" AS f(isotopic tracer idx, phase idx)
+                                           iqWIsoPha(:,:)       !--- INDEX IN "qx" AS f(H2O + isotopic tracer idx, phase idx)
+
+  !=== PARAMETERS FOR DEFAULT BEHAVIOUR
+  LOGICAL, PARAMETER :: lTracsMerge = .FALSE.                   !--- Merge/stack tracers lists
+  LOGICAL, PARAMETER :: lSortByGen  = .TRUE.                    !--- Sort by growing generation
 
   INTEGER,    PARAMETER :: maxTableWidth = 192                  !--- Maximum width of a table displayed with "dispTable"
@@ -179 +190 @@
 !     * If you need to convert a %key/%val pair into a direct-access key, add the corresponding line in "setDirectKeys".
 !==============================================================================================================================
-LOGICAL FUNCTION readTracersFiles(type_trac, lRepr) RESULT(lerr)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=*),  INTENT(IN)  :: type_trac                        !--- List of components used
-  LOGICAL, OPTIONAL, INTENT(IN)  :: lRepr                            !--- Activate the HNNO3 exceptions for REPROBUS
+LOGICAL FUNCTION readTracersFiles(type_trac, tracs, lRepr) RESULT(lerr)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=*),                               INTENT(IN)  :: type_trac     !--- List of components used
+  TYPE(trac_type), ALLOCATABLE, TARGET, OPTIONAL, INTENT(OUT) :: tracs(:)      !--- Tracers descriptor for external storage
+  LOGICAL,                              OPTIONAL, INTENT(IN)  :: lRepr         !--- Activate the HNO3 exceptions for REPROBUS
   CHARACTER(LEN=maxlen),  ALLOCATABLE :: s(:), sections(:), trac_files(:)
   CHARACTER(LEN=maxlen) :: str, fname, tname, pname, cname
   INTEGER               :: nsec, ierr, it, ntrac, ns, ip, ix, fType
+  INTEGER, ALLOCATABLE  :: iGen(:)
   LOGICAL :: lRep
   TYPE(keys_type), POINTER :: k
@@ -195 +208 @@
 
   !--- Required sections + corresponding files names (new style single section case) for tests
-  IF(test(testTracersFiles(modname, type_trac, fType, .FALSE., trac_files, sections), lerr)) RETURN
+  lerr = testTracersFiles(modname, type_trac, fType, .FALSE., trac_files, sections); IF(lerr) RETURN
   nsec = SIZE(sections)
 
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  SELECT CASE(fType)                         !--- Set %name, %genOName, %parent, %type, %phase, %component, %iGeneration, %keys
+  SELECT CASE(fType)                         !--- Set name, component, parent, phase, iGeneration, gen0Name, type
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     CASE(1)                                                          !=== OLD FORMAT "traceur.def"
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
       !--- OPEN THE "traceur.def" FILE
-      OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', IOSTAT=ierr)
+      OPEN(90, FILE="traceur.def", FORM='formatted', STATUS='old', POSITION='REWIND', IOSTAT=ierr)
 
       !--- GET THE TRACERS NUMBER
       READ(90,'(i3)',IOSTAT=ierr)ntrac                               !--- Number of lines/tracers
-      IF(test(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, ierr /= 0), lerr)) RETURN
+      lerr = ierr/=0; IF(fmsg('Invalid format for "'//TRIM(fname)//'"', modname, lerr)) RETURN
 
       !--- READ THE REMAINING LINES: <hadv> <vadv> <tracer> [<transporting fluid>]
-      IF(ALLOCATED(tracers)) DEALLOCATE(tracers)
       ALLOCATE(tracers(ntrac))
-      DO it=1,ntrac                                                  !=== READ RAW DATA: loop on the line/tracer number
+      DO it = 1, ntrac                                               !=== READ RAW DATA: loop on the line/tracer number
         READ(90,'(a)',IOSTAT=ierr) str
-        IF(test(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, ierr>0), lerr)) RETURN
-        IF(test(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, ierr<0), lerr)) RETURN
+        lerr = ierr>0; IF(fmsg('Invalid format for "' //TRIM(fname)//'"', modname, lerr)) RETURN
+        lerr = ierr<0; IF(fmsg('Not enough lines in "'//TRIM(fname)//'"', modname, lerr)) RETURN
         lerr = strParse(str, ' ', s, ns)
         CALL msg('This file is for air tracers only',           modname, ns == 3 .AND. it == 1)
@@ -226 +238 @@
         ix = strIdx(oldHNO3, s(3))
         IF(ix /= 0 .AND. lRep) tname = newHNO3(ix)                   !--- Exception for HNO3 (REPROBUS ONLY)
-        tracers(it)%name = tname                                     !--- Set %name
-        CALL addKey_1('name', tname, k)                              !--- Set the name of the tracer
+        tracers(it)%name = tname                                     !--- Set the name of the tracer
+        CALL addKey('name', tname, k)                                !--- Set the name of the tracer
         tracers(it)%keys%name = tname                                !--- Copy tracers names in keys components
 
@@ -233 +245 @@
         cname = type_trac                                            !--- Name of the model component
         IF(ANY([(addPhase('H2O', ip), ip = 1, nphases)] == tname)) cname = 'lmdz'
-        tracers(it)%component = cname                                !--- Set %component
-        CALL addKey_1('component', cname, k)                         !--- Set the name of the model component
+        tracers(it)%component = cname                                !--- Set component
+        CALL addKey('component', cname, k)                           !--- Set the name of the model component
 
         !=== NAME OF THE PARENT
@@ -243 +255 @@
           IF(ix /= 0 .AND. lRep) pname = newHNO3(ix)                 !--- Exception for HNO3 (REPROBUS ONLY)
         END IF
-        tracers(it)%parent = pname                                   !--- Set %parent
-        CALL addKey_1('parent', pname, k)
+        tracers(it)%parent = pname                                   !--- Set the parent name
+        CALL addKey('parent', pname, k)
 
         !=== PHASE AND ADVECTION SCHEMES NUMBERS
-        tracers(it)%phase = known_phases(ip:ip)                      !--- Set %phase:  tracer phase (default: "g"azeous)
-        CALL addKey_1('phase', known_phases(ip:ip), k)               !--- Set the phase  of the tracer (default: "g"azeous)
-        CALL addKey_1('hadv', s(1),  k)                              !--- Set the horizontal advection schemes number
-        CALL addKey_1('vadv', s(2),  k)                              !--- Set the vertical   advection schemes number
+        tracers(it)%phase = known_phases(ip:ip)                      !--- Set the phase of the tracer (default: "g"azeous)
+        CALL addKey('phase', known_phases(ip:ip), k)                 !--- Set the phase of the tracer (default: "g"azeous)
+        CALL addKey('hadv', s(1),  k)                                !--- Set the horizontal advection schemes number
+        CALL addKey('vadv', s(2),  k)                                !--- Set the vertical   advection schemes number
       END DO
       CLOSE(90)
-      IF(test(setGeneration(tracers), lerr)) RETURN                  !--- Set %iGeneration and %gen0Name
-      WHERE(tracers%iGeneration == 2) tracers(:)%type = 'tag'        !--- Set %type:        'tracer' or 'tag'
-      DO it=1,ntrac
-        CALL addKey_1('type', tracers(it)%type, tracers(it)%keys)    !--- Set the type of tracer
+      lerr = setGeneration(tracers); IF(lerr) RETURN                 !--- Set iGeneration and gen0Name
+      lerr = getKey('iGeneration', iGen, tracers(:)%keys)            !--- Generation number
+      WHERE(iGen == 2) tracers(:)%type = 'tag'                       !--- Set type:      'tracer' or 'tag'
+      DO it = 1, ntrac
+        CALL addKey('type', tracers(it)%type, tracers(it)%keys)      !--- Set the type of tracer
       END DO
-      IF(test(checkTracers(tracers, fname, fname), lerr)) RETURN     !--- Detect orphans and check phases
-      IF(test(checkUnique (tracers, fname, fname), lerr)) RETURN     !--- Detect repeated tracers
-      CALL sortTracers    (tracers)                                  !--- Sort the tracers
+      lerr = checkTracers(tracers, fname, fname); IF(lerr) RETURN    !--- Detect orphans and check phases
+      lerr = checkUnique (tracers, fname, fname); IF(lerr) RETURN    !--- Detect repeated tracers
+      CALL sortTracers   (tracers)                                   !--- Sort the tracers
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    CASE(2); IF(test(feedDBase(["tracer.def"], [type_trac], modname), lerr)) RETURN !=== SINGLE   FILE, MULTIPLE SECTIONS
+    CASE(2); lerr=feedDBase(["tracer.def"], [type_trac], modname); IF(lerr) RETURN  !=== SINGLE   FILE, MULTIPLE SECTIONS
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    CASE(3); IF(test(feedDBase(  trac_files  ,  sections,   modname), lerr)) RETURN !=== MULTIPLE FILES, SINGLE  SECTION
+    CASE(3); lerr=feedDBase(  trac_files  ,  sections,   modname); IF(lerr) RETURN  !=== MULTIPLE FILES, SINGLE  SECTION
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   END SELECT
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   IF(ALL([2,3] /= fType)) RETURN
-
-  IF(nsec  == 1) THEN; 
-    tracers = dBase(1)%trac
-  ELSE IF(tracs_merge) THEN
-    CALL msg('The multiple required sections will be MERGED.',    modname)
-    IF(test(mergeTracers(dBase, tracers), lerr)) RETURN
-  ELSE
-    CALL msg('The multiple required sections will be CUMULATED.', modname)
-    IF(test(cumulTracers(dBase, tracers), lerr)) RETURN
+  IF(nsec == 1) tracers = dBase(1)%trac
+  IF(nsec /= 1) THEN
+    CALL msg('Multiple sections are MERGED',    modname,      lTracsMerge)
+    CALL msg('Multiple sections are CUMULATED', modname, .NOT.lTracsMerge)
+    IF(     lTracsMerge) lerr = cumulTracers(dBase, tracers)
+    IF(.NOT.lTracsMerge) lerr = cumulTracers(dBase, tracers)
+    IF(lerr) RETURN
   END IF
-  CALL setDirectKeys(tracers)                                        !--- Set %iqParent, %iqDescen, %nqDescen, %nqChildren
+  lerr = indexUpdate(tracers); IF(lerr) RETURN                       !--- Set iqParent, iqDescen, nqDescen, nqChildren
+  IF(PRESENT(tracs)) CALL MOVE_ALLOC(FROM=tracers, TO=tracs)
 END FUNCTION readTracersFiles
 !==============================================================================================================================
@@ -299 +311 @@
   !--- PARSE "type_trac" LIST AND DETERMINE THE TRACERS FILES NAMES (FOR CASE 3: MULTIPLE FILES, SINGLE SECTION PER FILE)
   !--- If type_trac is a scalar (case 1), "sections" and "trac_files" are not usable, but are meaningless for case 1 anyway.
-  IF(test(strParse(type_trac, '|', sections,  n=nsec), lerr)) RETURN !--- Parse "type_trac" list
+  lerr = strParse(type_trac, '|', sections, n=nsec); IF(lerr) RETURN !--- Parse "type_trac" list
   IF(PRESENT(sects)) sects = sections
   ALLOCATE(trac_files(nsec), ll(nsec))
@@ -313 +325 @@
   IF(.NOT.lD) RETURN                                                 !--- NO CHECKING/DISPLAY NEEDED: JUST GET type_trac,fType
   IF(ANY(ll) .AND. fType/=3) THEN                                    !--- MISSING FILES
-    IF(test(checkList(trac_files, .NOT.ll, 'Failed reading tracers description', 'files', 'missing'), lerr)) RETURN
+    lerr = checkList(trac_files, .NOT.ll, 'Failed reading tracers description', 'files', 'missing'); IF(lerr) RETURN
   END IF
 
@@ -344 +356 @@
   ll = strCount(snames, '|', ndb)                                    !--- Number of sections for each file
   ALLOCATE(ixf(SUM(ndb)))
-  DO i=1, SIZE(fnames)                                               !--- Set %name, %keys
-    IF(test(readSections(fnames(i), snames(i), 'default'), lerr)) RETURN
+  DO i=1, SIZE(fnames)                                               !--- Set name, keys
+    lerr = readSections(fnames(i), snames(i), 'default'); IF(lerr) RETURN
     ixf(1+SUM(ndb(1:i-1)):SUM(ndb(1:i))) = i                         !--- File index for each section of the expanded list
   END DO
@@ -353 +365 @@
     fnm = fnames(ixf(idb)); snm = dBase(idb)%name                    !--- FILE AND SECTION NAMES
     lerr = ANY([(dispTraSection('RAW CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))])
-    IF(test(expandSection(dBase(idb)%trac, snm, fnm), lerr)) RETURN  !--- EXPAND NAMES ;  set %parent, %type, %component
-    IF(test(setGeneration(dBase(idb)%trac),           lerr)) RETURN  !---                 set %iGeneration,   %genOName
-    IF(test(checkTracers (dBase(idb)%trac, snm, fnm), lerr)) RETURN  !--- CHECK ORPHANS AND PHASES
-    IF(test(checkUnique  (dBase(idb)%trac, snm, fnm), lerr)) RETURN  !--- CHECK TRACERS UNIQUENESS
-    CALL expandPhases    (dBase(idb)%trac)                           !--- EXPAND PHASES ; set %phase
-    CALL sortTracers     (dBase(idb)%trac)                           !--- SORT TRACERS
+    lerr = expandSection(dBase(idb)%trac, snm, fnm); IF(lerr) RETURN !--- EXPAND NAMES ;  SET parent, type, component
+    lerr = setGeneration(dBase(idb)%trac);           IF(lerr) RETURN !---                 SET iGeneration,  genOName
+    lerr = checkTracers (dBase(idb)%trac, snm, fnm); IF(lerr) RETURN !--- CHECK ORPHANS AND PHASES
+    lerr = checkUnique  (dBase(idb)%trac, snm, fnm); IF(lerr) RETURN !--- CHECK TRACERS UNIQUENESS
+    lerr = expandPhases (dBase(idb)%trac);           IF(lerr) RETURN !--- EXPAND PHASES ; set phase
+    CALL sortTracers    (dBase(idb)%trac)                            !--- SORT TRACERS
     lerr = ANY([(dispTraSection('EXPANDED CONTENT OF SECTION "'//TRIM(snm)//'"', snm, modname), idb=1, SIZE(dBase))])
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
@@ -387 +399 @@
   ll = strParse(snam, '|', keys = sec)                               !--- Requested sections names
   ix = strIdx(dBase(:)%name, sec(:))                                 !--- Indexes of requested sections in database
-  IF(test(checkList(sec, ix == 0, 'In file "'//TRIM(fnam)//'"','section(s)', 'missing'), lerr)) RETURN
+  lerr = checkList(sec, ix == 0, 'In file "'//TRIM(fnam)//'"','section(s)', 'missing'); IF(lerr) RETURN
   tdb = dBase(:); dBase = [tdb(1:n0-1),tdb(PACK(ix, MASK=ix/=0))]    !--- Keep requested sections only
 
@@ -403 +415 @@
 !------------------------------------------------------------------------------------------------------------------------------
   IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
-  OPEN(90, FILE=fnam, FORM='formatted', STATUS='old')
+  OPEN(90, FILE=fnam, FORM='formatted', POSITION='REWIND', STATUS='old')
   DO; str=''
     DO
@@ -416 +428 @@
     IF(str(1:1)=='#') CYCLE                                          !--- Skip comments lines
     CALL removeComment(str)                                          !--- Skip comments at the end of a line
+    IF(LEN_TRIM(str) == 0) CYCLE                                     !--- Empty line (probably end of file)
     IF(str     == '') CYCLE                                          !--- Skip empty line (probably at the end of the file)
     IF(str(1:1)=='&') THEN                                           !=== SECTION HEADER LINE
@@ -431 +444 @@
       ll = strParse(str,' ', s, n, v)                                !--- Parse <key>=<val> pairs
       tt = dBase(ndb)%trac(:)
-      tmp%name = s(1); tmp%keys = keys_type(s(1), s(2:n), v(2:n))    !--- Set %name and %keys
+      v(1) = s(1); s(1) = 'name'                                     !--- Convert "name" into a regular key
+      tmp%name = v(1); tmp%keys = keys_type(v(1), s(:), v(:))        !--- Set %name and %keys
       dBase(ndb)%trac = [tt(:), tmp]
-      DEALLOCATE(tt)
-!      dBase(ndb)%trac = [dBase(ndb)%trac(:), tra(name=s(1), keys=keys_type(s(1), s(2:n), v(2:n)))]
+      DEALLOCATE(tt, tmp%keys%key, tmp%keys%val)
     END IF
   END DO
@@ -460 +473 @@
   ky => t(jd)%keys
   DO k = 1, SIZE(ky%key)                                             !--- Loop on the keys of the tracer named "defName"
-!   CALL addKey_m(ky%key(k), ky%val(k), t(:)%keys, .FALSE.)           !--- Add key to all the tracers (no overwriting)
-    DO it = 1, SIZE(t); CALL addKey_1(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO
+!   CALL addKey(ky%key(k), ky%val(k), t(:)%keys, .FALSE.)            !--- Add key to all the tracers (no overwriting)
+    DO it = 1, SIZE(t); CALL addKey(ky%key(k), ky%val(k), t(it)%keys, .FALSE.); END DO
   END DO
   tt = [t(1:jd-1),t(jd+1:SIZE(t))]; CALL MOVE_ALLOC(FROM=tt, TO=t)   !--- Remove the virtual tracer named "defName"
@@ -506 +519 @@
 !------------------------------------------------------------------------------------------------------------------------------
   TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:)                 !--- Tracer derived type vector
-  CHARACTER(LEN=*),             INTENT(IN)    :: sname
-  CHARACTER(LEN=*), OPTIONAL,   INTENT(IN)    :: fname
+  CHARACTER(LEN=*),             INTENT(IN)    :: sname                 !--- Current section name
+  CHARACTER(LEN=*), OPTIONAL,   INTENT(IN)    :: fname                 !--- Tracers description file name
   TYPE(trac_type),       ALLOCATABLE :: ttr(:)
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: ta(:), pa(:), tname(:), parent(:), dType(:)
   CHARACTER(LEN=maxlen) :: msg1, modname
   INTEGER :: it, nt, iq, nq, itr, ntr, ipr, npr
@@ -516 +529 @@
   lerr = .FALSE.
   nt = SIZE(tr)
+  lerr = getKey('name',   tname,  tr(:)%keys);                 IF(lerr) RETURN
+  lerr = getKey('parent', parent, tr(:)%keys, def = tran0);    IF(lerr) RETURN
+  lerr = getKey('type',   dType,  tr(:)%keys, def = 'tracer'); IF(lerr) RETURN
   nq = 0
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
@@ -521 +537 @@
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     !--- Extract useful keys: parent name, type, component name
-    tr(it)%parent    = fgetKey(it, 'parent', tr(:)%keys,  tran0  )
-    tr(it)%type      = fgetKey(it, 'type'  , tr(:)%keys, 'tracer')
     tr(it)%component = sname
-!   CALL addKey_m('component', sname, tr(:)%keys)
-    DO iq=1,SIZE(tr); CALL addKey_1('component', sname, tr(iq)%keys); END DO
+    CALL addKey('component', sname,  tr(it)%keys)
 
     !--- Determine the number of tracers and parents ; coherence checking
-    ll = strCount(tr(it)%name,   ',', ntr)
-    ll = strCount(tr(it)%parent, ',', npr)
+    ll = strCount( tname(it), ',', ntr)
+    ll = strCount(parent(it), ',', npr)
 
     !--- Tagging tracers only can have multiple parents
-    IF(test(npr/=1 .AND. TRIM(tr(it)%type)/='tag', lerr)) THEN
+    lerr = npr /=1 .AND. TRIM(dType(it)) /= 'tag'
+    IF(lerr) THEN
       msg1 = 'Check section "'//TRIM(sname)//'"'
-      IF(PRESENT(fname)) msg1=TRIM(msg1)//' in file "'//TRIM(fname)//'"'
-      CALL msg(TRIM(msg1)//': "'//TRIM(tr(it)%name)//'" has several parents but is not a tag', modname); RETURN
+      IF(PRESENT(fname)) msg1 = TRIM(msg1)//' in file "'//TRIM(fname)//'"'
+      CALL msg(TRIM(msg1)//': "'//TRIM(tname(it))//'" has several parents but is not a tag', modname); RETURN
     END IF
     nq = nq + ntr*npr                 
@@ -547 +561 @@
   DO it = 1, nt                                                      !=== EXPAND TRACERS AND PARENTS NAMES LISTS
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ll = strParse(tr(it)%name,   ',', ta, ntr)                       !--- Number of tracers
-    ll = strParse(tr(it)%parent, ',', pa, npr)                       !--- Number of parents
-    DO ipr=1,npr                                                     !--- Loop on parents list elts
-      DO itr=1,ntr                                                   !--- Loop on tracers list elts
+    ll = strParse( tname(it), ',', ta, ntr)                          !--- Number of tracers
+    ll = strParse(parent(it), ',', pa, npr)                          !--- Number of parents
+    DO ipr = 1, npr                                                  !--- Loop on parents list elts
+      DO itr = 1, ntr                                                !--- Loop on tracers list elts
+        ttr(iq)%keys%name = TRIM(ta(itr))
         ttr(iq)%keys%key  = tr(it)%keys%key
         ttr(iq)%keys%val  = tr(it)%keys%val
-        ttr(iq)%keys%name = ta(itr)
-        ttr(iq)%name      = TRIM(ta(itr));    CALL addKey_1('name',      ta(itr),          ttr(iq)%keys)
-        ttr(iq)%parent    = TRIM(pa(ipr));    CALL addKey_1('parent',    pa(ipr),          ttr(iq)%keys)
-        ttr(iq)%type      = tr(it)%type;      CALL addKey_1('type',      tr(it)%type,      ttr(iq)%keys)
-        ttr(iq)%component = tr(it)%component; CALL addKey_1('component', tr(it)%component, ttr(iq)%keys)
-        iq = iq+1
+        ttr(iq)%name      = TRIM(ta(itr))
+        ttr(iq)%parent    = TRIM(pa(ipr))
+        ttr(iq)%type      = dType(it)
+        ttr(iq)%component = sname
+        CALL addKey('name',      ta(itr),   ttr(iq)%keys)
+        CALL addKey('parent',    pa(ipr),   ttr(iq)%keys)
+        CALL addKey('type',      dType(it), ttr(iq)%keys)
+        CALL addKey('component', sname,     ttr(iq)%keys)
+        iq = iq + 1
       END DO
     END DO
@@ -575 +593 @@
 !------------------------------------------------------------------------------------------------------------------------------
 ! Purpose: Determine, for each tracer of "tr(:)":
-!   * %iGeneration: the generation number 
-!   * %gen0Name:    the generation 0 ancestor name
-!          Check also for orphan tracers (tracers not descending on "tran0").
+!   * iGeneration: the generation number 
+!   * gen0Name:    the generation 0 ancestor name
+!          Check also for orphan tracers (tracers without parent).
 !------------------------------------------------------------------------------------------------------------------------------
   TYPE(trac_type),     INTENT(INOUT) :: tr(:)                        !--- Tracer derived type vector
   INTEGER                            :: iq, jq, ig
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: parent(:), tname(:)
 !------------------------------------------------------------------------------------------------------------------------------
   CHARACTER(LEN=maxlen) :: modname
   modname = 'setGeneration'
-  IF(test(fmsg('missing "parent" attribute', modname, getKey('parent', parent, ky=tr(:)%keys)), lerr)) RETURN
+  lerr = getKey('name',   tname,  ky=tr(:)%keys); IF(lerr) RETURN
+  lerr = getKey('parent', parent, ky=tr(:)%keys); IF(lerr) RETURN
   DO iq = 1, SIZE(tr)
     jq = iq; ig = 0
     DO WHILE(parent(jq) /= tran0)
-      jq = strIdx(tr(:)%name, parent(jq))
-      IF(test(fmsg('Orphan tracer "'//TRIM(tr(iq)%name)//'"', modname, jq == 0), lerr)) RETURN
+      jq = strIdx(tname(:), parent(jq))
+      lerr = jq == 0
+      IF(fmsg('Orphan tracer "'//TRIM(tname(iq))//'"', modname, lerr)) RETURN
       ig = ig + 1
     END DO
-    tr(iq)%gen0Name = tr(jq)%name; CALL addKey_1('gen0Name',    tr(iq)%gen0Name,   tr(iq)%keys)
-    tr(iq)%iGeneration = ig;       CALL addKey_1('iGeneration', TRIM(int2str(ig)), tr(iq)%keys)
+    tr(iq)%gen0Name = tname(jq)
+    tr(iq)%iGeneration = ig
+    CALL addKey('iGeneration',   ig,  tr(iq)%keys)
+    CALL addKey('gen0Name', tname(jq), tr(iq)%keys)
   END DO
 END FUNCTION setGeneration
@@ -604 +626 @@
 !------------------------------------------------------------------------------------------------------------------------------
 ! Purpose:
-!   * check for orphan tracers (without known parent)
-!   * check wether the phases are known or not ("g"aseous, "l"iquid or "s"olid so far)
+!   * check for orphan tracers (without parent)
+!   * check wether the phases are known or not (elements of "known_phases")
 !------------------------------------------------------------------------------------------------------------------------------
   TYPE(trac_type),            INTENT(IN) :: tr(:)                    !--- Tracer derived type vector
   CHARACTER(LEN=*),           INTENT(IN) :: sname                    !--- Section name
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fname                    !--- File name
+  CHARACTER(LEN=1) :: p
   CHARACTER(LEN=maxlen) :: mesg
   CHARACTER(LEN=maxlen) :: bp(SIZE(tr, DIM=1)), pha                  !--- Bad phases list, phases of current tracer
-  CHARACTER(LEN=1) :: p
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:)
+  INTEGER,               ALLOCATABLE ::  iGen(:)
   INTEGER :: ip, np, iq, nq
 !------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: modname
+  modname = 'checkTracers'
   nq = SIZE(tr,DIM=1)                                                !--- Number of tracers lines
   mesg = 'Check section "'//TRIM(sname)//'"'
   IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
+  lerr = getKey('iGeneration', iGen, tr(:)%keys);               IF(lerr) RETURN
+  lerr = getKey('name',       tname, tr(:)%keys);               IF(lerr) RETURN
 
   !=== CHECK FOR ORPHAN TRACERS
-  IF(test(checkList(tr%name, tr%iGeneration==-1, mesg, 'tracers', 'orphan'), lerr)) RETURN
+  lerr = checkList(tname, iGen==-1, mesg, 'tracers', 'orphan'); IF(lerr) RETURN
 
   !=== CHECK PHASES
-  DO iq=1,nq; IF(tr(iq)%iGeneration/=0) CYCLE                        !--- Generation O only is checked
-    pha = fgetKey(iq, 'phases', tr(:)%keys, 'g')                     !--- Phases
+  DO iq = 1, nq; IF(iGen(iq) /= 0) CYCLE                             !--- Generation O only is checked
+    IF(getKey(['phases','phase '], pha, iq, tr(:)%keys, lDisp=.FALSE.)) pha = 'g'   !--- Phase
     np = LEN_TRIM(pha); bp(iq)=' '
-    DO ip=1,np; p = pha(ip:ip); IF(INDEX(known_phases,p)==0) bp(iq) = TRIM(bp(iq))//p; END DO
-    IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tr(iq)%name)//': '//TRIM(bp(iq))
+    DO ip = 1, np; p = pha(ip:ip); IF(INDEX(known_phases, p) == 0) bp(iq) = TRIM(bp(iq))//p; END DO
+    IF(TRIM(bp(iq)) /= '') bp(iq) = TRIM(tname(iq))//': '//TRIM(bp(iq))
   END DO
-  lerr = checkList(bp, tr%iGeneration==0 .AND. bp/='', mesg, 'tracers phases', 'unknown')
+  lerr = checkList(bp, iGen == 0 .AND. bp /= '', mesg, 'tracers phases', 'unknown')
 END FUNCTION checkTracers
 !==============================================================================================================================
@@ -645 +673 @@
   INTEGER :: ip, np, iq, nq, k
   LOGICAL, ALLOCATABLE  :: ll(:)
-  CHARACTER(LEN=maxlen) :: mesg, tnam, tdup(SIZE(tr,DIM=1))
-  CHARACTER(LEN=1)      :: p
-!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: mesg, phase, tdup(SIZE(tr,DIM=1))
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), dType(:)
+  INTEGER,               ALLOCATABLE :: iGen(:)
+  CHARACTER(LEN=1) :: p
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: modname
+  modname = 'checkUnique'
   mesg = 'Check section "'//TRIM(sname)//'"'
   IF(PRESENT(fname)) mesg=TRIM(mesg)//' in file "'//TRIM(fname)//'"'
   nq=SIZE(tr,DIM=1); lerr=.FALSE.                                    !--- Number of lines ; error flag
   tdup(:) = ''
-  DO iq=1,nq; IF(tr(iq)%type == 'tag') CYCLE                         !--- Tags can be repeated
-    tnam = TRIM(tr(iq)%name)
-    ll = tr(:)%name==TRIM(tnam)                                      !--- Mask for current tracer name
-    IF(COUNT(ll)==1 ) CYCLE                                          !--- Tracer is not repeated
-    IF(tr(iq)%iGeneration>0) THEN
-      tdup(iq) = tnam                                                !--- gen>0: MUST be unique
+  lerr = getKey('name',       tname, tr%keys); IF(lerr) RETURN
+  lerr = getKey('type',       dType, tr%keys); IF(lerr) RETURN
+  lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN
+  DO iq = 1, nq
+    IF(dType(iq) == 'tag') CYCLE                                     !--- Tags can be repeated
+    ll = tname==TRIM(tname(iq))                                      !--- Mask for current tracer name
+    IF(COUNT(ll) == 1) CYCLE                                         !--- Tracer is not repeated
+    IF(iGen(iq) > 0) THEN
+      tdup(iq) = tname(iq)                                           !--- gen>0: MUST be unique
     ELSE
-      DO ip=1,nphases; p=known_phases(ip:ip)                         !--- Loop on known phases
-        !--- Number of appearances of the current tracer with known phase "p"
-        np = COUNT( PACK( [(INDEX(fgetKey(k, 'phases', tr(:)%keys, 'g'),p), k=1, nq)] /=0 , MASK=ll ) )
-        IF(np <=1) CYCLE
-        tdup(iq) = TRIM(tdup(iq))//TRIM(phases_names(ip))
+      DO ip = 1, nphases; p = known_phases(ip:ip)                    !--- Loop on known phases
+        np = 0
+        DO k = 1, nq
+          IF(.NOT.ll(k)) CYCLE                                       !--- Skip tracers different from current one
+          IF(getKey(['phases','phase '], phase, k, tr%keys, lDisp=.FALSE.)) phase='g'!--- Get current phases
+          IF(INDEX(phase, p) /= 0) np = np + 1                       !--- One more appearance of current tracer with phase "p"
+        END DO
+        IF(np <= 1) CYCLE                                            !--- Regular case: no or a single appearance
+        tdup(iq) = TRIM(tdup(iq))//TRIM(phases_names(ip))            !--- Repeated phase
         IF(ANY(tdup(1:iq-1) == tdup(iq))) tdup(iq)=''                !--- Avoid repeating same messages
       END DO
     END IF
-    IF(tdup(iq) /= '') tdup(iq)=TRIM(tnam)//' in '//TRIM(tdup(iq))//' phase(s)'
+    IF(tdup(iq) /= '') tdup(iq)=TRIM(tname(iq))//' in '//TRIM(tdup(iq))//' phase(s)'
   END DO
   lerr = checkList(tdup, tdup/='', mesg, 'tracers', 'duplicated')
@@ -675 +714 @@
 
 !==============================================================================================================================
-SUBROUTINE expandPhases(tr)
+LOGICAL FUNCTION expandPhases(tr) RESULT(lerr)
 !------------------------------------------------------------------------------------------------------------------------------
 ! Purpose: Expand the phases in the tracers descriptor "tr". Phases are not repeated for a tracer, thanks to "checkUnique".
@@ -681 +720 @@
   TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:)               !--- Tracer derived type vector
 !------------------------------------------------------------------------------------------------------------------------------
-  TYPE(trac_type), ALLOCATABLE :: ttr(:)
-  INTEGER,   ALLOCATABLE ::  i0(:)
-  CHARACTER(LEN=maxlen)  :: nam, pha, tname
+  TYPE(trac_type),       ALLOCATABLE :: ttr(:)
+  INTEGER,               ALLOCATABLE ::  i0(:), iGen(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:), phase(:), parents(:), dType(:)
+  CHARACTER(LEN=maxlen)              ::  nam,     gen0Nm,   pha,      parent
   CHARACTER(LEN=1) :: p
   INTEGER :: ip, np, iq, jq, nq, it, nt, nc, i, n
   LOGICAL :: lTag, lExt
 !------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: modname
+  modname = 'expandPhases'
   nq = SIZE(tr, DIM=1)
   nt = 0
+  lerr = getKey('name',       tname, tr%keys); IF(lerr) RETURN       !--- Names of the tracers
+  lerr = getKey('gen0Name',   gen0N, tr%keys); IF(lerr) RETURN       !--- Names of the tracers of first generation
+  lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN       !--- Generation number
+  lerr = getKey('phases',     phase, tr%keys); IF(lerr) RETURN       !--- Phases names
+  lerr = getKey('parent',   parents, tr%keys); IF(lerr) RETURN       !--- Parents names
+  lerr = getKey('type',       dType, tr%keys); IF(lerr) RETURN       !--- Tracers types ('tracer' or 'tag')
   DO iq = 1, nq                                                      !--- GET THE NUMBER OF TRACERS
-    IF(tr(iq)%iGeneration /= 0) CYCLE                                !--- Only deal with generation 0 tracers
-    nc = COUNT(tr(:)%gen0Name==tr(iq)%name .AND. tr%iGeneration/=0)  !--- Number of children of tr(iq)
-    tr(iq)%phase = fgetKey(iq, 'phases', tr(:)%keys)                 !--- Phases list        of tr(iq)
-    np = LEN_TRIM(tr(iq)%phase)                                      !--- Number of phases   of tr(iq)
+    IF(iGen(iq) /= 0) CYCLE                                          !--- Only deal with generation 0 tracers
+    nc = COUNT(gen0N == tname(iq) .AND. iGen /= 0)                   !--- Number of children of tr(iq)
+    np = LEN_TRIM(phase(iq))                                         !--- Number of phases   of tr(iq)
     nt = nt + (1+nc) * np                                            !--- Number of tracers after expansion
   END DO
@@ -700 +747 @@
   it = 1                                                             !--- Current "ttr(:)" index
   DO iq = 1, nq                                                      !--- Loop on "tr(:)" indexes
-    lTag = tr(iq)%type=='tag'                                        !--- Current tracer is a tag
-    i0 = strFind(tr(:)%name, TRIM(tr(iq)%gen0Name), n)               !--- Indexes of first generation ancestor copies
-    np = SUM([( LEN_TRIM(tr(i0(i))%phase),i=1,n )], 1)               !--- Number of phases for current tracer tr(iq)
-    lExt = np>1                                                      !--- Phase suffix only required if phases number is > 1
-    IF(lTag) lExt = lExt .AND. tr(iq)%iGeneration>0                  !--- No phase suffix for generation 0 tags
-    DO i=1,n                                                         !=== LOOP ON GENERATION 0 ANCESTORS
+    lTag = dType(iq)=='tag'                                          !--- Current tracer is a tag
+    i0 = strFind(tname, TRIM(gen0N(iq)), n)                          !--- Indexes of first generation ancestor copies
+    np = SUM([( LEN_TRIM(phase(i0(i))), i = 1, n )], 1)              !--- Number of phases for current tracer tr(iq)
+    lExt = np > 1                                                    !--- Phase suffix only required if phases number is > 1
+    IF(lTag) lExt = lExt .AND. iGen(iq) > 0                          !--- No phase suffix for generation 0 tags
+    DO i = 1, n                                                      !=== LOOP ON GENERATION 0 ANCESTORS
       jq = i0(i)                                                     !--- tr(jq): ith tracer with same gen 0 ancestor as tr(iq)
-      IF(tr(iq)%iGeneration==0) jq=iq                                !--- Generation 0: count the current tracer phases only
-      pha = tr(jq)%phase                                             !--- Phases list for tr(jq)
+      IF(iGen(iq) == 0) jq = iq                                      !--- Generation 0: count the current tracer phases only
+      pha = phase(jq)                                                !--- Phases list for tr(jq)
       DO ip = 1, LEN_TRIM(pha)                                       !=== LOOP ON PHASES LISTS
         p = pha(ip:ip)
-        tname = TRIM(tr(iq)%name); nam = tname                       !--- Tracer name (regular case)
-        IF(lTag) nam = TRIM(tr(iq)%parent)                           !--- Parent name (tagging case)
+        nam = tname(iq)                                              !--- Tracer name (regular case)
+        IF(lTag) nam = TRIM(parents(iq))                             !--- Parent name (tagging case)
         IF(lExt) nam = addPhase(nam, p )                             !--- Phase extension needed
-        IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname)                   !--- <parent>_<name> for tags
+        IF(lTag) nam = TRIM(nam)//'_'//TRIM(tname(iq))               !--- <parent>_<name> for tags
         ttr(it) = tr(iq)                                             !--- Same <key>=<val> pairs
         ttr(it)%name      = TRIM(nam)                                !--- Name with possibly phase suffix
         ttr(it)%keys%name = TRIM(nam)                                !--- Name inside the keys decriptor
         ttr(it)%phase     = p                                        !--- Single phase entry
-        CALL addKey_1('name', nam, ttr(it)%keys)
-        CALL addKey_1('phase', p,  ttr(it)%keys)
-        IF(lExt .AND. tr(iq)%iGeneration>0) THEN
-          ttr(it)%parent   = addPhase(tr(iq)%parent,   p)
-          ttr(it)%gen0Name = addPhase(tr(iq)%gen0Name, p)
-          CALL addKey_1('parent',   ttr(it)%parent,   ttr(it)%keys)
-          CALL addKey_1('gen0Name', ttr(it)%gen0Name, ttr(it)%keys)
+        CALL addKey('name', nam, ttr(it)%keys)
+        CALL addKey('phase', p,  ttr(it)%keys)
+        IF(lExt) THEN
+          parent = parents(iq); IF(iGen(iq) > 0) parent = addPhase(parent, p)
+          gen0Nm =   gen0N(iq); IF(iGen(iq) > 0) gen0Nm = addPhase(gen0Nm, p)
+          ttr(it)%parent   = parent
+          ttr(it)%gen0Name = gen0Nm
+          CALL addKey('parent',   parent, ttr(it)%keys)
+          CALL addKey('gen0Name', gen0Nm, ttr(it)%keys)
         END IF
         it = it+1
       END DO
-      IF(tr(iq)%iGeneration==0) EXIT                                 !--- Break phase loop for gen 0
+      IF(iGen(iq) == 0) EXIT                                         !--- Break phase loop for gen 0
     END DO
   END DO
@@ -735 +784 @@
   CALL delKey(['phases'],tr)                                         !--- Remove few keys entries
 
-END SUBROUTINE expandPhases
+END FUNCTION expandPhases
 !==============================================================================================================================
 
@@ -748 +797 @@
 !   TO BE ADDED IF NECESSARY: HIGHER MOMENTS AT THE END
 !------------------------------------------------------------------------------------------------------------------------------
-  TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tr(:)         !--- Tracer derived type vector
-!------------------------------------------------------------------------------------------------------------------------------
-  TYPE(trac_type), ALLOCATABLE        :: tr2(:)
-  INTEGER,         ALLOCATABLE        :: iy(:), iz(:)
-  INTEGER                             :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k
+  TYPE(trac_type), INTENT(INOUT) :: tr(:)                            !--- Tracer derived type vector
+!------------------------------------------------------------------------------------------------------------------------------
+  TYPE(trac_type),       ALLOCATABLE :: tr2(:)
+  INTEGER,               ALLOCATABLE :: iy(:), iz(:)
+  INTEGER,               ALLOCATABLE ::  iGen(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), gen0N(:)
+  INTEGER :: ig, ng, iq, jq, ip, nq, n, ix(SIZE(tr)), k
+  LOGICAL :: lerr
 !  tr2 is introduced in order to cope with a bug in gfortran 4.8.5 compiler
 !------------------------------------------------------------------------------------------------------------------------------
+  lerr = getKey('iGeneration', iGen, tr%keys); IF(lerr) RETURN       !--- Generation number
   nq = SIZE(tr)
   DO ip = nphases, 1, -1
-    iq = strIdx(tr(:)%name, addPhase('H2O', ip))
+    lerr = getKey('name',     tname, tr%keys); IF(lerr) RETURN       !--- Names of the tracers of first generation
+    iq = strIdx(tname, addPhase('H2O', ip))
     IF(iq == 0) CYCLE
     tr2 = tr(:)
@@ -764 +818 @@
   IF(lSortByGen) THEN
     iq = 1
-    ng = MAXVAL(tr(:)%iGeneration, MASK=.TRUE., DIM=1)               !--- Number of generations
+    ng = MAXVAL(iGen, MASK=.TRUE., DIM=1)                            !--- Number of generations
     DO ig = 0, ng                                                    !--- Loop on generations
-      iy = PACK([(k, k=1, nq)], MASK=tr(:)%iGeneration==ig)          !--- Generation ig tracers indexes
+      iy = PACK([(k, k=1, nq)], MASK=iGen(:) == ig)                  !--- Generation ig tracers indexes
       n = SIZE(iy)
       ix(iq:iq+n-1) = iy                                             !--- Stack growing generations idxs
@@ -772 +826 @@
     END DO
   ELSE
-    iq = 1
+    lerr = getKey('gen0Name',   gen0N, tr%keys); IF(lerr) RETURN     !--- Names of the tracers    iq = 1
     DO jq = 1, nq                                                    !--- Loop on generation 0 tracers
-      IF(tr(jq)%iGeneration /= 0) CYCLE                              !--- Skip generations /= 0
+      IF(iGen(jq) /= 0) CYCLE                                        !--- Skip generations /= 0
       ix(iq) = jq                                                    !--- Generation 0 ancestor index first
       iq = iq + 1                                                    !--- Next "iq" for next generations tracers
-      iy = strFind(tr(:)%gen0Name, TRIM(tr(jq)%name))                !--- Indexes of "tr(jq)" children in "tr(:)"
-      ng = MAXVAL(tr(iy)%iGeneration, MASK=.TRUE., DIM=1)            !--- Number of generations of the "tr(jq)" family
+      iy = strFind(gen0N(:), TRIM(tname(jq)))                        !--- Indices of "tr(jq)" children in "tr(:)"
+      ng = MAXVAL(iGen(iy), MASK=.TRUE., DIM=1)                      !--- Number of generations of the "tr(jq)" family
       DO ig = 1, ng                                                  !--- Loop   on generations of the "tr(jq)" family
-        iz = find(tr(iy)%iGeneration, ig, n)                         !--- Indexes of the tracers "tr(iy(:))" of generation "ig"
+        iz = find(iGen(iy), ig, n)                                   !--- Indices of the tracers "tr(iy(:))" of generation "ig"
         ix(iq:iq+n-1) = iy(iz)                                       !--- Same indexes in "tr(:)"
         iq = iq + n
@@ -796 +850 @@
   TYPE(trac_type), ALLOCATABLE, INTENT(OUT) ::       tr(:)
   TYPE(trac_type), POINTER ::   t1(:),   t2(:)
+  TYPE(keys_type), POINTER ::   k1(:),   k2(:)
   INTEGER,     ALLOCATABLE :: ixct(:), ixck(:)
-  INTEGER :: is, k1, k2, nk2, i1, i2, nt2
+  INTEGER :: is, ik, ik1, ik2, nk2, i1, i2, nt2
   CHARACTER(LEN=maxlen) :: s1, v1, v2, tnam, knam, modname
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: keys(:), n1(:), n2(:)
   modname = 'mergeTracers'
   lerr = .FALSE.
-  t1 => sections(1)%trac(:)                                          !--- Alias: first tracers section
+  keys = ['parent     ', 'type       ', 'iGeneration']               !--- Mandatory keys
+  t1 => sections(1)%trac(:); k1 => t1(:)%keys                        !--- Alias: first tracers section, corresponding keys
+  lerr = getKey('name', n1, k1); IF(lerr) RETURN                     !--- Names of the tracers
   tr = t1
   !----------------------------------------------------------------------------------------------------------------------------
@@ -807 +865 @@
   !----------------------------------------------------------------------------------------------------------------------------
     t2  => sections(is)%trac(:)                                      !--- Alias: current tracers section
+    k2  => t2(:)%keys
+    lerr = getKey('name', n2, k2); IF(lerr) RETURN                   !--- Names of the tracers
     nt2  = SIZE(t2(:), DIM=1)                                        !--- Number of tracers in section
-    ixct = strIdx(t1(:)%name, t2(:)%name)                            !--- Indexes of common tracers
+    ixct = strIdx(n1(:), n2(:))                                      !--- Indexes of common tracers
     tr = [tr, PACK(t2, MASK= ixct==0)]                               !--- Append with new tracers
     IF( ALL(ixct == 0) ) CYCLE                                       !--- No common tracers => done
     CALL msg('Tracers defined in previous sections and duplicated in "'//TRIM(sections(is)%name)//'":', modname)
-    CALL msg(t1(PACK(ixct, MASK = ixct/=0))%name, modname, nmax=128) !--- Display duplicates (the 128 first at most)
+    CALL msg(n1(PACK(ixct, MASK = ixct/=0)), modname, nmax=128)      !--- Display duplicates (the 128 first at most)
     !--------------------------------------------------------------------------------------------------------------------------
     DO i2=1,nt2; tnam = TRIM(t2(i2)%name)                            !=== LOOP ON COMMON TRACERS
@@ -820 +880 @@
       !=== CHECK WETHER ESSENTIAL KEYS ARE IDENTICAL OR NOT
       s1=' of "'//TRIM(tnam)//'" in "'//TRIM(sections(is)%name)//'" not matching previous value'
-      
-      IF(test(fmsg('Parent name'//TRIM(s1), modname, t1(i1)%parent      /= t2(i2)%parent),      lerr)) RETURN
-      IF(test(fmsg('Type'       //TRIM(s1), modname, t1(i1)%type        /= t2(i2)%type),        lerr)) RETURN
-      IF(test(fmsg('Generation' //TRIM(s1), modname, t1(i1)%iGeneration /= t2(i2)%iGeneration), lerr)) RETURN
-
-      !=== APPEND <key>=<val> PAIRS NOT PREVIOULSLY DEFINED
-      nk2  = SIZE(t2(i2)%keys%key(:))                                !--- Keys number in current section
-      ixck = strIdx(t1(i1)%keys%key(:), t2(i2)%keys%key(:))          !--- Common keys indexes
-
-      !=== APPEND NEW KEYS
+      DO ik = 1, SIZE(keys)
+        lerr = getKey(keys(ik), v1, i1, k1)
+        lerr = getKey(keys(ik), v2, i2, k2)
+        lerr = v1 /= v2; IF(fmsg(TRIM(keys(ik))//TRIM(s1), modname, lerr)) RETURN
+      END DO
+
+      !=== GET THE INDICES IN tr(i2)%keys%key(:) OF THE KEYS ALSO PRESENT IN tr(i1)%keys%key(:)
+      nk2  =   SIZE(k2(i2)%key(:))                                   !--- Keys number in current section
+      ixck = strIdx(k1(i1)%key(:), k2(i2)%key(:))                    !--- Common keys indexes
+      !--- APPEND THE NEW KEYS PAIRS IN tr(i1)%keys%key(:)
       tr(i1)%keys%key = [ tr(i1)%keys%key, PACK(tr(i2)%keys%key, MASK = ixck==0)]
       tr(i1)%keys%val = [ tr(i1)%keys%val, PACK(tr(i2)%keys%val, MASK = ixck==0)]
 
-      !--- KEEP TRACK OF THE COMPONENTS NAMES
-      tr(i1)%component = TRIM(tr(i1)%component)//','//TRIM(tr(i2)%component)
-
-      !--- SELECT COMMON TRACERS WITH DIFFERING KEYS VALUES (PREVIOUS VALUE IS KEPT)
-      DO k2=1,nk2
-        k1 = ixck(k2); IF(k1 == 0) CYCLE
-        IF(t1(i1)%keys%val(k1) == t2(i2)%keys%val(k2)) ixck(k2)=0
+      !=== KEEP TRACK OF THE COMPONENTS NAMES: COMA-SEPARATED LIST
+      lerr = getKey('component', v1, i1, k1)
+      lerr = getKey('component', v2, i2, k2)
+      tr(i1)%component = TRIM(v1)//','//TRIM(v2)
+      CALL addKey('component', TRIM(v1)//','//TRIM(v2), tr(i1)%keys)
+
+      !=== FOR TRACERS COMMON TO PREVIOUS AND CURRENT SECTIONS: CHECK WETHER SOME KEYS HAVE DIFFERENT VALUES ; KEEP OLD ONE
+      DO ik2 = 1, nk2                                                !--- Collect the corresponding indices
+        ik1 = ixck(ik2); IF(ik1 == 0) CYCLE
+        IF(k1(i1)%val(ik1) == k2(i2)%val(ik2)) ixck(ik2)=0
       END DO
-      IF(ALL(ixck==0)) CYCLE                                         !--- No identical keys with /=values
-
-      !--- DISPLAY INFORMATION: OLD VALUES ARE KEPT FOR THE KEYS FOUND IN PREVIOUS AND CURRENT SECTIONS
-      CALL msg('Key(s)'//TRIM(s1), modname)
-      DO k2 = 1, nk2                                                 !--- Loop on keys found in both t1(:) and t2(:)
-        knam = t2(i2)%keys%key(k2)                                   !--- Name of the current key
-        k1 = ixck(k2)                                                !--- Corresponding index in t1(:)
-        IF(k1 == 0) CYCLE                                            !--- New keys are skipped
-        v1 = t1(i1)%keys%val(k1); v2 = t2(i2)%keys%val(k2)           !--- Key values in t1(:) and t2(:)
+      IF(ALL(ixck==0)) CYCLE                                         !--- No identical keys with /=values => nothing to display
+      CALL msg('Key(s)'//TRIM(s1), modname)                          !--- Display the  keys with /=values (names list)
+      DO ik2 = 1, nk2                                                !--- Loop on keys found in both t1(:) and t2(:)
+        knam = k2(i2)%key(ik2)                                       !--- Name of the current key
+        ik1 = ixck(ik2)                                              !--- Corresponding index in t1(:)
+        IF(ik1 == 0) CYCLE                                           !--- New keys are skipped
+        v1 = k1(i1)%val(ik1); v2 = k2(i2)%val(ik2)                   !--- Key values in t1(:) and t2(:)
         CALL msg(' * '//TRIM(knam)//'='//TRIM(v2)//' ; previous value kept:'//TRIM(v1), modname)
       END DO
@@ -862 +923 @@
 
 !==============================================================================================================================
-LOGICAL FUNCTION cumulTracers(sections, tr) RESULT(lerr)
+LOGICAL FUNCTION cumulTracers(sections, tr, lRename) RESULT(lerr)
   TYPE(dataBase_type),  TARGET, INTENT(IN)  :: sections(:)
   TYPE(trac_type), ALLOCATABLE, INTENT(OUT) ::       tr(:)
-  TYPE(trac_type), POINTER     :: t(:)
-  INTEGER,   ALLOCATABLE :: nt(:)
-  CHARACTER(LEN=maxlen)  :: tnam, tnam_new
-  INTEGER :: iq, nq, is, ns, nsec
-  lerr = .FALSE.                                                     !--- Can't fail ; kept to match "mergeTracer" interface.
-  nsec =  SIZE(sections)
-  tr = [(      sections(is)%trac(:) , is=1, nsec )]                  !--- Concatenated tracers vector
-  nt = [( SIZE(sections(is)%trac(:)), is=1, nsec )]                  !--- Number of tracers in each section
+  LOGICAL,            OPTIONAL, INTENT(IN)  :: lRename               !--- .TRUE.: add a section suffix to identical names
+  CHARACTER(LEN=maxlen)  :: tnam_new, modname
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), comp(:)
+  INTEGER :: iq, jq, is
+  modname = 'cumulTracers'
+  lerr = .FALSE.
+  tr = [( sections(is)%trac(:), is = 1, SIZE(sections) )]            !--- Concatenated tracers vector
+  IF(PRESENT(lRename)) THEN; IF(lRename) RETURN; END IF              !--- No renaming: finished
+  lerr = getKey('name',     tname, tr%keys); IF(lerr) RETURN         !--- Names
+  lerr = getKey('parent',  parent, tr%keys); IF(lerr) RETURN         !--- Parents
+  lerr = getKey('component', comp, tr%keys); IF(lerr) RETURN         !--- Component name
   !----------------------------------------------------------------------------------------------------------------------------
-  DO is=1, nsec                                                      !=== LOOP ON SECTIONS
+  DO iq = 1, SIZE(tr); IF(COUNT(tname == tname(iq)) == 1) CYCLE      !=== LOOP ON TRACERS
   !----------------------------------------------------------------------------------------------------------------------------
-    t => sections(is)%trac(:)
+    tnam_new = TRIM(tname(iq))//'_'//TRIM(comp(iq))                  !--- Same with section extension
+    CALL addKey('name', tnam_new, tr(iq)%keys)                       !--- Modify tracer name
+    tr(iq)%name = TRIM(tnam_new)                                     !--- Modify tracer name
     !--------------------------------------------------------------------------------------------------------------------------
-    DO iq=1, nt(is)                                                  !=== LOOP ON TRACERS
+    DO jq = 1, SIZE(tr); IF(parent(jq) /= tname(iq)) CYCLE           !=== LOOP ON TRACERS PARENTS
     !--------------------------------------------------------------------------------------------------------------------------
-      tnam = TRIM(t(iq)%name)                                        !--- Original name
-      IF(COUNT(t%name == tnam) == 1) CYCLE                           !--- Current tracer is not duplicated: finished
-      tnam_new = TRIM(tnam)//'_'//TRIM(sections(is)%name)            !--- Same with section extension
-      nq = SUM(nt(1:is-1))                                           !--- Number of tracers in previous sections
-      ns = nt(is)                                                    !--- Number of tracers in the current section
-      tr(iq + nq)%name = TRIM(tnam_new)                              !--- Modify tracer name
-      WHERE(tr(1+nq:ns+nq)%parent==tnam) tr(1+nq:ns+nq)%parent=tnam_new  !--- Modify parent name
+      CALL addKey('parent', tnam_new, tr(jq)%keys)                   !--- Modify tracer name
+      tr(jq)%parent = TRIM(tnam_new)                                 !--- Modify tracer name
     !--------------------------------------------------------------------------------------------------------------------------
     END DO
@@ -896 +957 @@
 !==============================================================================================================================
 
-!==============================================================================================================================
-SUBROUTINE setDirectKeys(tr)
+
+!==============================================================================================================================
+LOGICAL  FUNCTION  dispTraSection(message, sname, modname) RESULT(lerr)
+  CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:,:), n(:), tmp(:)
+  CHARACTER(LEN=maxlen) :: p
+  INTEGER :: idb, iq, nq
+  idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN
+  nq = SIZE(dBase(idb)%trac)
+  p = ''
+  CALL append(['iq'],     .TRUE. ); IF(lerr) RETURN
+  CALL append(['name'],   .TRUE. ); IF(lerr) RETURN
+  CALL append(['phases','phase '], .FALSE., 'pha'); IF(lerr) RETURN
+  CALL append(['hadv'],   .TRUE. ); IF(lerr) RETURN
+  CALL append(['vadv'],   .TRUE. ); IF(lerr) RETURN
+  CALL append(['parent'], .FALSE.); IF(lerr) RETURN
+  CALL append(['iGen'],   .FALSE.); IF(lerr) RETURN
+  CALL msg(TRIM(message)//':', modname)
+  lerr = dispTable(p, n, s, nColMax=maxTableWidth, nHead=2, sub=modname); IF(lerr) RETURN
+
+CONTAINS
+
+SUBROUTINE append(nam, lMandatory, snam)
+! Test whether key named "nam(:)" is available.
+!  * yes: - get its value for all species in "tmp(:)" and append table "s(:,:)" with it
+!         - append titles list with "nam(1)" (or, if specified, "snam", usually a short name).
+!  * no:  return to calling routine with an error flag if the required key is mandatory
+  CHARACTER(LEN=*),           INTENT(IN) :: nam(:)
+  LOGICAL,                    INTENT(IN) :: lMandatory
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: snam
+  INTEGER :: m
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: n0(:)
+  CHARACTER(LEN=maxlen) :: nm
+  lerr = .FALSE.
+  IF(nam(1) == 'iq') THEN
+    tmp = int2str([(iq, iq=1, nq)])
+  ELSE
+    lerr = getKey(nam, tmp, dBase(idb)%trac(:)%keys, lDisp=lMandatory)
+  END IF
+  IF(lerr) THEN; lerr = lMandatory; RETURN; END IF
+  nm = nam(1); IF(PRESENT(snam)) nm = snam
+  p = TRIM(p)//'s'
+  IF(ALLOCATED(s)) THEN; s = cat(s, tmp); ELSE; ALLOCATE(s(nq,1)); s(:,1) = tmp; END IF
+  IF(ALLOCATED(n)) THEN; m = SIZE(n); ALLOCATE(n0(m+1)); n0(1:m)=n; n0(m+1)=nm; CALL MOVE_ALLOC(FROM=n0, TO=n)
+  ELSE; n=nam(1:1); END IF
+END SUBROUTINE append
+
+END FUNCTION dispTraSection
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== CREATE TRACER(S) ALIAS: SCALAR/VECTOR FROM NAME(S) OR INDICE(S) ==========================================================
+!==============================================================================================================================
+LOGICAL FUNCTION aliasTracer(tname, trac, alias) RESULT(lerr)                  !=== TRACER NAMED "tname" - SCALAR
+  CHARACTER(LEN=*),         INTENT(IN)  :: tname
+  TYPE(trac_type), TARGET,  INTENT(IN)  :: trac(:)
+  TYPE(trac_type), POINTER, INTENT(OUT) :: alias
+  INTEGER :: it
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
+  alias => NULL()
+  lerr = getKey('name', tnames, trac(:)%keys)
+  it = strIdx(tnames, tname)
+  lerr = it /= 0; IF(.NOT.lerr) alias => trac(it)
+END FUNCTION aliasTracer
+!==============================================================================================================================
+LOGICAL FUNCTION trSubset_Indx(trac, idx, alias) RESULT(lerr)                  !=== TRACERS WITH INDICES "idx(:)" - VECTOR
+  TYPE(trac_type), ALLOCATABLE, INTENT(IN)  ::  trac(:)
+  INTEGER,                      INTENT(IN)  ::   idx(:)
+  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)
+  alias = trac(idx)
+  lerr = indexUpdate(alias)
+END FUNCTION trSubset_Indx
+!------------------------------------------------------------------------------------------------------------------------------
+LOGICAL FUNCTION trSubset_Name(trac, tname, alias) RESULT(lerr)                !=== TRACERS NAMED "tname(:)" - VECTOR
+  TYPE(trac_type), ALLOCATABLE, INTENT(IN)  ::  trac(:)
+  CHARACTER(LEN=*),             INTENT(IN)  :: tname(:)
+  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
+  lerr = getKey('name', tnames, trac(:)%keys)
+  alias = trac(strIdx(tnames, tname))
+  lerr = indexUpdate(alias)
+END FUNCTION trSubset_Name
+!==============================================================================================================================
+LOGICAL FUNCTION trSubset_gen0Name(trac, gen0Nm, alias) RESULT(lerr)           !=== TRACERS OF COMMON 1st GENERATION ANCESTOR
+  TYPE(trac_type), ALLOCATABLE, INTENT(IN)  :: trac(:)
+  CHARACTER(LEN=*),             INTENT(IN)  :: gen0Nm
+  TYPE(trac_type), ALLOCATABLE, INTENT(OUT) :: alias(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: gen0N(:)
+  lerr = getKey('gen0Name', gen0N, trac(:)%keys)
+  alias = trac(strFind(delPhase(gen0N), gen0Nm))
+  lerr = indexUpdate(alias)
+END FUNCTION trSubset_gen0Name
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) =========
+!==============================================================================================================================
+LOGICAL FUNCTION indexUpdate(tr) RESULT(lerr)
   TYPE(trac_type), INTENT(INOUT) :: tr(:)
-
-  !--- Update %iqParent, %iqDescen, %nqDescen, %nqChildren
-  CALL indexUpdate(tr)
-
-  !--- Extract some direct-access keys
-!  DO iq = 1, SIZE(tr)
-!    tr(iq)%keys%<key> = getKey_prv(it, "<key>", tr%keys, <default_value> )
-!  END DO
-END SUBROUTINE setDirectKeys
-!==============================================================================================================================
-
-!==============================================================================================================================
-LOGICAL FUNCTION dispTraSection(message, sname, modname) RESULT(lerr)
-  CHARACTER(LEN=*), INTENT(IN) :: message, sname, modname
-  INTEGER :: idb, iq, nq
-  INTEGER, ALLOCATABLE :: hadv(:), vadv(:)
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: phas(:), prnt(:)
-  TYPE(trac_type), POINTER :: tm(:)
-  lerr = .FALSE.
-  idb = strIdx(dBase(:)%name, sname); IF(idb == 0) RETURN
-  tm => dBase(idb)%trac
-  nq = SIZE(tm)
-  !--- BEWARE ! Can't use the "getKeyByName" functions yet.
-  !             Names must first include the phases for tracers defined on multiple lines.
-  hadv = str2int(fgetKeys('hadv',  tm(:)%keys, '10'))
-  vadv = str2int(fgetKeys('vadv',  tm(:)%keys, '10'))
-  prnt =         fgetKeys('parent',tm(:)%keys,  '' )
-  IF(getKey('phases', phas, ky=tm(:)%keys)) phas = fGetKeys('phase', tm(:)%keys, 'g')
-  CALL msg(TRIM(message)//':', modname)
-  IF(ALL(prnt == 'air')) THEN
-    IF(test(dispTable('iiiss',   ['iq    ','hadv  ','vadv  ','name  ','phase '],                   cat(tm%name,       phas),  &
-                 cat([(iq, iq=1, nq)], hadv, vadv),                 nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
-  ELSE IF(ALL(tm%iGeneration == -1)) THEN
-    IF(test(dispTable('iiisss', ['iq    ','hadv  ','vadv  ','name  ','parent','phase '],           cat(tm%name, prnt, phas),  &
-                 cat([(iq, iq=1, nq)], hadv, vadv),                 nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
-  ELSE
-    IF(test(dispTable('iiissis', ['iq    ','hadv  ','vadv  ','name  ','parent','igen  ','phase '], cat(tm%name, prnt, phas),  &
-                 cat([(iq, iq=1, nq)], hadv, vadv, tm%iGeneration), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
-  END IF
-END FUNCTION dispTraSection
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!== CREATE A SCALAR ALIAS OF THE COMPONENT OF THE TRACERS DESCRIPTOR "t" NAMED "tname" ========================================
-!==============================================================================================================================
-FUNCTION aliasTracer(tname, t) RESULT(out)
-  TYPE(trac_type),         POINTER    :: out
-  CHARACTER(LEN=*),        INTENT(IN) :: tname
-  TYPE(trac_type), TARGET, INTENT(IN) :: t(:)
-  INTEGER :: it
-  it = strIdx(t(:)%name, tname)
-  out => NULL(); IF(it /= 0) out => t(it)
-END FUNCTION aliasTracer
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== FROM A LIST OF INDEXES OR NAMES, CREATE A SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" ==================================
-!==============================================================================================================================
-FUNCTION trSubset_Indx(trac,idx) RESULT(out)
-  TYPE(trac_type), ALLOCATABLE             ::  out(:)
-  TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
-  INTEGER,                      INTENT(IN) ::  idx(:)
-  out = trac(idx)
-  CALL indexUpdate(out)
-END FUNCTION trSubset_Indx
-!------------------------------------------------------------------------------------------------------------------------------
-FUNCTION trSubset_Name(trac,nam) RESULT(out)
-  TYPE(trac_type), ALLOCATABLE             ::  out(:)
-  TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
-  CHARACTER(LEN=*),             INTENT(IN) ::  nam(:)
-  out = trac(strIdx(trac(:)%name, nam))
-  CALL indexUpdate(out)
-END FUNCTION trSubset_Name
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== CREATE THE SUBSET OF THE TRACERS DESCRIPTORS LIST "trac" HAVING THE FIRST GENERATION ANCESTOR NAMED "nam" ================
-!==============================================================================================================================
-FUNCTION trSubset_gen0Name(trac,nam) RESULT(out)
-  TYPE(trac_type), ALLOCATABLE             ::  out(:)
-  TYPE(trac_type), ALLOCATABLE, INTENT(IN) :: trac(:)
-  CHARACTER(LEN=*),             INTENT(IN) ::  nam
-  out = trac(strFind(delPhase(trac(:)%gen0Name), nam))
-  CALL indexUpdate(out)
-END FUNCTION trSubset_gen0Name
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== UPDATE THE INDEXES iqParent, iqDescend AND iGeneration IN THE TRACERS DESCRIPTOR LIST "tr" (USEFULL FOR SUBSETS) =========
-!==============================================================================================================================
-SUBROUTINE indexUpdate(tr)
-  TYPE(trac_type), INTENT(INOUT) :: tr(:)
-  INTEGER :: iq, ig, igen, ngen, ix(SIZE(tr))
-  tr(:)%iqParent = strIdx( tr(:)%name, tr(:)%parent )                !--- Parent index
-  DO iq = 1, SIZE(tr); CALL addKey_1('iqParent', int2str(tr(iq)%iqParent), tr(iq)%keys); END DO
-  ngen = MAXVAL(tr(:)%iGeneration, MASK=.TRUE.)
-  DO iq = 1, SIZE(tr)
-    ig = tr(iq)%iGeneration
-    IF(ALLOCATED(tr(iq)%iqDescen)) DEALLOCATE(tr(iq)%iqDescen)
-    ALLOCATE(tr(iq)%iqDescen(0))
-    CALL idxAncestor(tr, ix, ig)                                     !--- Ancestor of generation "ng" for each tr
-    DO igen = ig+1, ngen
-      tr(iq)%iqDescen = [tr(iq)%iqDescen, find(ix==iq .AND. tr%iGeneration==igen)]
-      tr(iq)%nqDescen = SIZE(tr(iq)%iqDescen)
-      IF(igen == ig+1) THEN
-        tr(iq)%nqChildren = tr(iq)%nqDescen
-        CALL addKey_1('nqChildren', int2str(tr(iq)%nqChildren), tr(iq)%keys)
-      END IF
+  INTEGER :: iq, jq, nq, ig, nGen
+  INTEGER,               ALLOCATABLE :: iqDescen(:), ix(:), iy(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:), parent(:)
+  INTEGER,       DIMENSION(SIZE(tr)) :: iqParent, iGen
+  lerr = getKey('name',   tnames, tr%keys); IF(lerr) RETURN          !--- Names
+  lerr = getKey('parent', parent, tr%keys); IF(lerr) RETURN          !--- Parents
+  nq = SIZE(tr)
+
+  !=== iqParent, iGeneration
+  DO iq = 1, nq; iGen(iq) = 0; jq = iq
+    iqParent(iq) = strIdx(tnames, parent(iq))
+    DO; jq = strIdx(tnames, parent(jq)); IF(jq == 0) EXIT; iGen(iq) = iGen(iq) + 1; END DO
+    CALL addKey('iqParent',   parent(iq), tr(iq)%keys)
+    CALL addKey('iqGeneration', iGen(iq), tr(iq)%keys)
+  END DO
+
+  !=== nqChildren, iqDescen, nqDescen
+  nGen = MAXVAL(iGen, MASK=.TRUE.)
+  DO iq = 1, nq
+    ix = [iq]; ALLOCATE(iqDescen(0))
+    DO ig = iGen(iq)+1, nGen
+      iy = find(iqParent, ix); iqDescen = [iqDescen, iy]; ix = iy
+      IF(ig /= iGen(iq)+1) CYCLE
+      CALL addKey('nqChildren', SIZE(iqDescen), tr(iq)%keys)
+      tr(iq)%nqChildren = SIZE(iqDescen)
     END DO
-    CALL addKey_1('iqDescen', strStack(int2str(tr(iq)%iqDescen)), tr(iq)%keys)
-    CALL addKey_1('nqDescen',          int2str(tr(iq)%nqDescen) , tr(iq)%keys)
+    CALL addKey('iqDescen', strStack(int2str(iqDescen)), tr(iq)%keys)
+    CALL addKey('nqDescen',             SIZE(iqDescen),  tr(iq)%keys)
+    tr(iq)%iqDescen =      iqDescen
+    tr(iq)%nqDescen = SIZE(iqDescen)
+    DEALLOCATE(iqDescen)
   END DO
-END SUBROUTINE indexUpdate
+END FUNCTION indexUpdate
 !==============================================================================================================================
   
@@ -1024 +1099 @@
 !===  * For each isotopes class, the <key>=<val> vector of each tracer is moved into the isotopes descriptor "isot"        ====
 !=== NOTES:                                                                                                                ====
-!===  * Most of the "isot" components have been defined in the calling routine (readIsotopes):                             ====
+!===  * Most of the "isot" components have been defined in the calling routine (processIsotopes):                          ====
 !===      parent,  nzone, zone(:),  niso, keys(:)%name,  ntiso, trac(:),  nphas, phas,  iqIsoPha(:,:),  itZonPhi(:,:)      ====
 !===  * Same syntax for isotopes file and "tracer.def": a tracers section contains one line for each of its isotopes       ====
@@ -1032 +1107 @@
 !===  * The routine gives an error if a required isotope is not available in the database stored in "fnam"                 ====
 !==============================================================================================================================
-LOGICAL FUNCTION readIsotopesFile_prv(fnam, isot) RESULT(lerr)
+LOGICAL FUNCTION readIsotopesFile(fnam, isot) RESULT(lerr)
   CHARACTER(LEN=*),        INTENT(IN)    :: fnam                     !--- Input file name
   TYPE(isot_type), TARGET, INTENT(INOUT) :: isot(:)                  !--- Isotopes descriptors (field %parent must be defined!)
@@ -1049 +1124 @@
   !--- READ THE FILE SECTIONS, ONE EACH PARENT TRACER
   nb0 = SIZE(dBase, DIM=1)+1                                         !--- Next database element index
-  IF(test(readSections(fnam,strStack(isot(:)%parent,'|')),lerr)) RETURN !--- Read sections, one each parent tracer
+  lerr = readSections(fnam,strStack(isot(:)%parent,'|')); IF(lerr) RETURN !--- Read sections, one each parent tracer
   ndb = SIZE(dBase, DIM=1)                                           !--- Current database size
   DO idb = nb0, ndb
@@ -1067 +1142 @@
       is = strIdx(isot(iis)%keys(:)%name, t%name)                    !--- Index in "isot(iis)%keys(:)%name" of isotope "t%name"
       IF(is == 0) CYCLE
-      IF(test(ANY(reduceExpr(t%keys%val, vals)), lerr)) RETURN       !--- Reduce expressions ; detect non-numerical elements
+      lerr = ANY(reduceExpr(t%keys%val, vals)); IF(lerr) RETURN      !--- Reduce expressions ; detect non-numerical elements
       isot(iis)%keys(is)%key = t%keys%key
       isot(iis)%keys(is)%val = vals
@@ -1073 +1148 @@
 
     !--- CHECK FOR MISSING ISOTOPES (NO KEYS ALLOCATED)
-    IF(test(checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &
-      'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing'), lerr)) RETURN
+    lerr = checkList(isot(iis)%keys(:)%name, .NOT.[( ALLOCATED(isot(iis)%keys(is)%key), is=1, SIZE(isot(iis)%keys) )], &
+                     'Check file "'//TRIM(fnam)//'" in section "'//TRIM(dBase(idb)%name)//'"', 'isotopes', 'missing')
+    IF(lerr) RETURN
   END DO
 
@@ -1109 +1185 @@
       END DO
     END DO
-    IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, &
-            cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname)), lerr)) RETURN
+    lerr = dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname)
+    IF(fmsg('Problem with the table content', modname, lerr)) RETURN
     DEALLOCATE(ttl, val)
   END DO        
@@ -1116 +1192 @@
 !------------------------------------------------------------------------------------------------------------------------------
 
-END FUNCTION readIsotopesFile_prv
+END FUNCTION readIsotopesFile
 !==============================================================================================================================
 
@@ -1124 +1200 @@
 !===    * COMPUTE MOST OF THE RELATED QUANTITIES ("isot" COMPONENTS).                                                       ===
 !===    * COMPUTE FEW ISOTOPES-DEDICATED "trac" COMPONENTS                                                                  ===
-!===    * CALL readIsotopesFile_prv TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS)                                          ===
+!===    * CALL readIsotopesFile TO GET PHYSICAL QUANTITIES (<key>=<val> PAIRS)                                              ===
 !===      NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS.  ===
 !==============================================================================================================================
-LOGICAL FUNCTION readIsotopesFile(iNames) RESULT(lerr)
+LOGICAL FUNCTION processIsotopes(iNames) RESULT(lerr)
   CHARACTER(LEN=maxlen), TARGET, OPTIONAL, INTENT(IN)  :: iNames(:)
   CHARACTER(LEN=maxlen), ALLOCATABLE :: p(:), str(:)                 !--- Temporary storage
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:), parent(:), dType(:), phase(:), gen0N(:)
   CHARACTER(LEN=maxlen) :: iName, modname
   CHARACTER(LEN=1)   :: ph                                           !--- Phase
+  INTEGER, ALLOCATABLE ::  iGen(:)
   INTEGER :: ic, ip, iq, it, iz
   LOGICAL, ALLOCATABLE :: ll(:)                                      !--- Mask
   TYPE(trac_type), POINTER   ::  t(:), t1
   TYPE(isot_type), POINTER   ::  i
+
   lerr = .FALSE.
   modname = 'readIsotopesFile'
@@ -1141 +1220 @@
   t => tracers
 
+  lerr = getKey('name',       tname, t%keys); IF(lerr) RETURN       !--- Names
+  lerr = getKey('parent',    parent, t%keys); IF(lerr) RETURN       !--- Parents
+  lerr = getKey('type',       dType, t%keys); IF(lerr) RETURN       !--- Tracer type
+  lerr = getKey('phase',      phase, t%keys); IF(lerr) RETURN       !--- Phase
+  lerr = getKey('gen0Name',   gen0N, t%keys); IF(lerr) RETURN       !--- 1st generation ancestor name
+  lerr = getKey('iGeneration', iGen, t%keys); IF(lerr) RETURN       !--- Generation number
+
   !--- GET FROM "tracers" THE FULL LIST OF AVAILABLE ISOTOPES CLASSES
-  p = PACK(delPhase(t%parent), MASK = t%type=='tracer' .AND. t%iGeneration==1)
+  p = PACK(delPhase(parent), MASK = dType=='tracer' .AND. iGen==1)
   CALL strReduce(p, nbIso)
 
@@ -1148 +1234 @@
   IF(PRESENT(iNames)) THEN
     DO it = 1, SIZE(iNames)
-      IF(test(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, ALL(p /= iNames(it))), lerr)) RETURN
+      lerr = ALL(p /= iNames(it))
+      IF(fmsg('No isotopes class "'//TRIM(iNames(it))//'" found among tracers', modname, lerr)) RETURN
     END DO
     p = iNames; nbIso = SIZE(p)
@@ -1164 +1251 @@
 
     !=== Isotopes children of tracer "iname": mask, names, number (same for each phase of "iname")
-    ll = t(:)%type=='tracer' .AND. delPhase(t(:)%parent) == iname .AND. t(:)%phase == 'g'
-    str = PACK(delPhase(t(:)%name), MASK = ll)                       !--- Effectively found isotopes of "iname"
+    ll = dType=='tracer' .AND. delPhase(parent) == iname .AND. phase == 'g'
+    str = PACK(delPhase(tname), MASK = ll)                           !--- Effectively found isotopes of "iname"
     i%niso = SIZE(str)                                               !--- Number of "effectively found isotopes of "iname"
     ALLOCATE(i%keys(i%niso))
@@ -1171 +1258 @@
 
     !=== Geographic tagging tracers descending on tracer "iname": mask, names, number
-    ll = t(:)%type=='tag'    .AND. delPhase(t(:)%gen0Name) == iname .AND. t(:)%iGeneration == 2
-    i%zone = PACK(strTail(t(:)%name,'_',.TRUE.), MASK = ll)          !--- Tagging zones names  for isotopes category "iname"
+    ll = dType=='tag'    .AND. delPhase(gen0N) == iname .AND. iGen == 2
+    i%zone = PACK(strTail(tname,'_',.TRUE.), MASK = ll)              !--- Tagging zones names  for isotopes category "iname"
     CALL strReduce(i%zone)
     i%nzone = SIZE(i%zone)                                           !--- Tagging zones number for isotopes category "iname"
@@ -1178 +1265 @@
     !=== Geographic tracers of the isotopes children of tracer "iname" (same for each phase of "iname")
     !    NOTE: One might like to create a similar variable for 2nd generation tagging tracers (tagging the gen1 tracers)
-    str = PACK(delPhase(t(:)%name), MASK=ll)
+    str = PACK(delPhase(tname), MASK=ll)
     CALL strReduce(str)
     i%ntiso = i%niso + SIZE(str)                                     !--- Number of isotopes + their geographic tracers [ntiso]
@@ -1205 +1292 @@
     i%iqIsoPha = RESHAPE( [( (strIdx(t%name,  addPhase(i%trac(it),i%phase(ip:ip))),       it=1, i%ntiso), ip=1, i%nphas)], &
                          [i%ntiso, i%nphas] )
+    !=== Table used to get iq (index in dyn array, size nqtot) from the water and isotope and phase indexes ; the full isotopes list
+    !    (including tagging tracers) is sorted this way:  iso1, iso2, ..., iso1_zone1, iso2_zone1, ..., iso1_zoneN, iso2_zoneN
+    i%iqWIsoPha = RESHAPE( [( [strIdx(t%name,   addPhase('H2O',i%phase(ip:ip))), i%iqIsoPha(:,ip)], ip=1,i%nphas)], &
+                         [1+i%ntiso, i%nphas] )
     !=== Table used to get ix (index in tagging tracers isotopes list, size ntiso) from the zone and isotope indexes
     i%itZonIso = RESHAPE( [( (strIdx(i%trac(:), TRIM(i%trac(it))//'_'//TRIM(i%zone(iz))), iz=1, i%nzone), it=1, i%niso )], &
@@ -1211 +1302 @@
 
   !=== READ PHYSICAL PARAMETERS FROM isoFile FILE
-  IF(test(readIsotopesFile_prv(isoFile, isotopes), lerr)) RETURN
+!  lerr = readIsotopesFile(isoFile, isotopes); IF(lerr) RETURN! on commente pour ne pas chercher isotopes_params.def
+
+  !--- GET THE isoCheck ENTRY FROM THE *.DEF FILES (MIGHT BE CHANGED TO A CLASS-DEPENDANT KEYWORD)
+  CALL get_in('ok_iso_verif', isoCheck, .TRUE.)
 
   !=== CHECK CONSISTENCY
-  IF(test(testIsotopes(), lerr)) RETURN
-
-  !=== SELECT FIRST ISOTOPES CLASS OR, IF POSSIBLE, WATER CLASS
-  IF(.NOT.test(isoSelect(1, .TRUE.), lerr)) THEN; IF(isotope%parent == 'H2O') iH2O = ixIso; END IF
+  lerr = testIsotopes(); IF(lerr) RETURN
+
+  !=== SELECT WATER ISOTOPES CLASS OR, IF UNFOUND, THE FIRST ISOTOPES CLASS
+  IF(isoSelect('H2O', .TRUE.)) THEN; iH2O = ixIso; ELSE; lerr = isoSelect(1, .TRUE.); END IF
 
 CONTAINS
@@ -1224 +1318 @@
 LOGICAL FUNCTION testIsotopes() RESULT(lerr)     !--- MAKE SURE MEMBERS OF AN ISOTOPES FAMILY ARE PRESENT IN THE SAME PHASES
 !------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ix, it, ip, np, iz, nz
+  INTEGER :: ix, it, ip, np, iz, nz, npha, nzon
   TYPE(isot_type), POINTER :: i
   DO ix = 1, nbIso
     i => isotopes(ix)
     !--- Check whether each isotope and tagging isotopic tracer is present in the same number of phases
-    DO it = 1, i%ntiso
-      np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, i%nphas)])
-      IF(test(fmsg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(i%nphas))//' for '//TRIM(i%trac(it)), &
-        modname, np /= i%nphas), lerr)) RETURN
+    DO it = 1, i%ntiso; npha = i%nphas
+      np = SUM([(COUNT(tracers(:)%name == addPhase(i%trac(it), i%phase(ip:ip))), ip=1, npha)])
+      lerr = np /= npha
+      CALL msg(TRIM(int2str(np))//' phases instead of '//TRIM(int2str(npha))//' for '//TRIM(i%trac(it)), modname, lerr)
+      IF(lerr) RETURN
     END DO
-    DO it = 1, i%niso
-      nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, i%nzone)])
-      IF(test(fmsg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(i%nzone))//' for '//TRIM(i%trac(it)), &
-        modname, nz /= i%nzone), lerr)) RETURN
+    DO it = 1, i%niso; nzon = i%nzone
+      nz = SUM([(COUNT(i%trac == TRIM(i%trac(it))//'_'//i%zone(iz)), iz=1, nzon)])
+      lerr = nz /= nzon
+      CALL msg(TRIM(int2str(nz))//' tagging zones instead of '//TRIM(int2str(nzon))//' for '//TRIM(i%trac(it)), modname, lerr)
+      IF(lerr) RETURN
     END DO
   END DO
@@ -1243 +1339 @@
 !------------------------------------------------------------------------------------------------------------------------------
 
-END FUNCTION readIsotopesFile
+END FUNCTION processIsotopes
 !==============================================================================================================================
 
@@ -1259 +1355 @@
    lV = .FALSE.; IF(PRESENT(lVerbose)) lV = lVerbose
    iIso = strIdx(isotopes(:)%parent, iName)
-   IF(test(iIso == 0, lerr)) THEN
+   lerr = iIso == 0
+   IF(lerr) THEN
       niso = 0; ntiso = 0; nzone = 0; nphas = 0; isoCheck=.FALSE.
       CALL msg('no isotope family named "'//TRIM(iName)//'"', ll=lV)
@@ -1287 +1384 @@
    itZonIso => isotope%itZonIso; isoCheck = isotope%check
    iqIsoPha => isotope%iqIsoPha
+   iqWIsoPha => isotope%iqWIsoPha
 END FUNCTION isoSelectByIndex
 !==============================================================================================================================
@@ -1294 +1392 @@
 !=== ADD THE <key>=<val> PAIR TO THE "ky[(:)]" KEY[S] DESCRIPTOR[S] OR THE <key>=<val(:)> PAIRS TO THE "ky(:)" KEYS DESCRIPTORS
 !==============================================================================================================================
-SUBROUTINE addKey_1(key, val, ky, lOverWrite)
-  CHARACTER(LEN=*),  INTENT(IN)    :: key, val
+SUBROUTINE addKey_s11(key, sval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key, sval
   TYPE(keys_type),   INTENT(INOUT) :: ky
   LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
@@ -1305 +1403 @@
   IF(.NOT.ALLOCATED(ky%key)) THEN
     ALLOCATE(ky%key(1)); ky%key(1)=key
-    ALLOCATE(ky%val(1)); ky%val(1)=val
+    ALLOCATE(ky%val(1)); ky%val(1)=sval
     RETURN
   END IF
@@ -1311 +1409 @@
   IF(iky == 0) THEN
     nky = SIZE(ky%key)
-    ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key; ky%key = k
-    ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = val; ky%val = v
+    ALLOCATE(k(nky+1)); k(1:nky) = ky%key; k(nky+1) = key;  ky%key = k
+    ALLOCATE(v(nky+1)); v(1:nky) = ky%val; v(nky+1) = sval; ky%val = v
   ELSE IF(lo) THEN
-    ky%key(iky) = key; ky%val(iky) = val
+    ky%key(iky) = key; ky%val(iky) = sval
   END IF
-END SUBROUTINE addKey_1
-!==============================================================================================================================
-SUBROUTINE addKey_m(key, val, ky, lOverWrite)
-  CHARACTER(LEN=*),  INTENT(IN)    :: key, val
+END SUBROUTINE addKey_s11
+!==============================================================================================================================
+SUBROUTINE addKey_i11(key, ival, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  INTEGER,           INTENT(IN)    :: ival
+  TYPE(keys_type),   INTENT(INOUT) :: ky
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  CALL addKey_s11(key, int2str(ival), ky, lOverWrite)
+END SUBROUTINE addKey_i11
+!==============================================================================================================================
+SUBROUTINE addKey_r11(key, rval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  REAL,              INTENT(IN)    :: rval
+  TYPE(keys_type),   INTENT(INOUT) :: ky
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  CALL addKey_s11(key, real2str(rval), ky, lOverWrite)
+END SUBROUTINE addKey_r11
+!==============================================================================================================================
+SUBROUTINE addKey_l11(key, lval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  LOGICAL,           INTENT(IN)    :: lval
+  TYPE(keys_type),   INTENT(INOUT) :: ky
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  CALL addKey_s11(key, bool2str(lval), ky, lOverWrite)
+END SUBROUTINE addKey_l11
+!==============================================================================================================================
+!==============================================================================================================================
+SUBROUTINE addKey_s1m(key, sval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key, sval
   TYPE(keys_type),   INTENT(INOUT) :: ky(:)
   LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
 !------------------------------------------------------------------------------------------------------------------------------
   INTEGER :: itr
-  DO itr = 1, SIZE(ky)
-    CALL addKey_1(key, val, ky(itr), lOverWrite)
-  END DO
-END SUBROUTINE addKey_m
-!==============================================================================================================================
-SUBROUTINE addKey_mm(key, val, ky, lOverWrite)
-  CHARACTER(LEN=*),  INTENT(IN)    :: key, val(:)
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, sval, ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_s1m
+!==============================================================================================================================
+SUBROUTINE addKey_i1m(key, ival, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  INTEGER,           INTENT(IN)    :: ival
   TYPE(keys_type),   INTENT(INOUT) :: ky(:)
   LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
 !------------------------------------------------------------------------------------------------------------------------------
   INTEGER :: itr
-  DO itr = 1, SIZE(ky); CALL addKey_1(key, val(itr), ky(itr), lOverWrite); END DO
-END SUBROUTINE addKey_mm
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_i1m
+!==============================================================================================================================
+SUBROUTINE addKey_r1m(key, rval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  REAL,              INTENT(IN)    :: rval
+  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: itr
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_r1m
+!==============================================================================================================================
+SUBROUTINE addKey_l1m(key, lval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  LOGICAL,           INTENT(IN)    :: lval
+  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: itr
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_l1m
+!==============================================================================================================================
+!==============================================================================================================================
+SUBROUTINE addKey_smm(key, sval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key, sval(:)
+  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: itr
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, sval(itr), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_smm
+!==============================================================================================================================
+SUBROUTINE addKey_imm(key, ival, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  INTEGER,           INTENT(IN)    :: ival(:)
+  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: itr
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, int2str(ival(itr)), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_imm
+!==============================================================================================================================
+SUBROUTINE addKey_rmm(key, rval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  REAL,              INTENT(IN)    :: rval(:)
+  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: itr
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, real2str(rval(itr)), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_rmm
+!==============================================================================================================================
+SUBROUTINE addKey_lmm(key, lval, ky, lOverWrite)
+  CHARACTER(LEN=*),  INTENT(IN)    :: key
+  LOGICAL,           INTENT(IN)    :: lval(:)
+  TYPE(keys_type),   INTENT(INOUT) :: ky(:)
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lOverWrite
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: itr
+  DO itr = 1, SIZE(ky); CALL addKey_s11(key, bool2str(lval(itr)), ky(itr), lOverWrite); END DO
+END SUBROUTINE addKey_lmm
 !==============================================================================================================================
 
@@ -1353 +1538 @@
   DO ik = 1, SIZE(t(jd)%keys%key)
     CALL get_in(t(jd)%keys%key(ik), val, '*none*')
-    IF(val /= '*none*') CALL addKey_1(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)
+    IF(val /= '*none*') CALL addKey(t(jd)%keys%key(ik), val, t(jd)%keys, .TRUE.)
   END DO
 END SUBROUTINE addKeysFromDef
@@ -1387 +1572 @@
 
 !==============================================================================================================================
-!================ GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RESULT IS THE RETURNED VALUE ===================
-!==============================================================================================================================
-CHARACTER(LEN=maxlen) FUNCTION fgetKeyIdx_s1(itr, keyn, ky, def_val, lerr) RESULT(val)
+!===   INTERNAL FUNCTION: GET THE VALUE OF A KEY FOR "itr"th TRACER FROM A "keys_type" DERIVED TYPE AND RETURN THE RESULT   ===
+!===   IF keyn CONTAINS SEVERAL ELEMENTS, TRY WITH EACH ELEMENT ONE AFTER THE OTHER                                         ===
+!==============================================================================================================================
+CHARACTER(LEN=maxlen) FUNCTION fgetKeyIdx(itr, keyn, ky, lerr) RESULT(val)
   INTEGER,                    INTENT(IN)  :: itr
-  CHARACTER(LEN=*),           INTENT(IN)  :: keyn
+  CHARACTER(LEN=*),           INTENT(IN)  :: keyn(:)
   TYPE(keys_type),            INTENT(IN)  :: ky(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: def_val
   LOGICAL,          OPTIONAL, INTENT(OUT) :: lerr
 !------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: ik
+  LOGICAL :: ler
+  ler = .TRUE.
+  DO ik = 1, SIZE(keyn)
+    CALL getKeyIdx(keyn(ik)); IF(.NOT.ler) EXIT
+  END DO
+  IF(PRESENT(lerr)) lerr = ler
+
+CONTAINS
+
+SUBROUTINE getKeyIdx(keyn)
+  CHARACTER(LEN=*), INTENT(IN) :: keyn
+!------------------------------------------------------------------------------------------------------------------------------
   INTEGER :: iky
-  LOGICAL :: ler
   iky = 0; val = ''
-  IF(.NOT.test(itr <= 0 .OR. itr > SIZE(ky), ler)) iky = strIdx(ky(itr)%key(:), keyn)    !--- Correct index
-  IF(.NOT.test(iky == 0, ler))                     val = ky(itr)%val(iky)                !--- Found key
-  IF(iky == 0) THEN
-    IF(.NOT.test(.NOT.PRESENT(def_val), ler))      val = def_val                         !--- Default value
-  END IF
-  IF(PRESENT(lerr)) lerr = ler
-END FUNCTION fgetKeyIdx_s1
-!==============================================================================================================================
-CHARACTER(LEN=maxlen) FUNCTION fgetKeyNam_s1(tname, keyn, ky, def_val, lerr) RESULT(val)
-  CHARACTER(LEN=*),           INTENT(IN)  :: tname, keyn
-  TYPE(keys_type),            INTENT(IN)  :: ky(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: def_val
-  LOGICAL,          OPTIONAL, INTENT(OUT) :: lerr
-!------------------------------------------------------------------------------------------------------------------------------
-  val = fgetKeyIdx_s1(strIdx(ky(:)%name, tname), keyn, ky, def_val, lerr)
-END FUNCTION fgetKeyNam_s1
-!==============================================================================================================================
-FUNCTION fgetKeys(keyn, ky, def_val, lerr) RESULT(val)
-CHARACTER(LEN=maxlen),        ALLOCATABLE :: val(:)
-  CHARACTER(LEN=*),           INTENT(IN)  :: keyn
-  TYPE(keys_type),            INTENT(IN)  :: ky(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: def_val
-  LOGICAL,          OPTIONAL, INTENT(OUT) :: lerr
-!------------------------------------------------------------------------------------------------------------------------------
-  LOGICAL :: ler(SIZE(ky))
-  INTEGER :: it
-  val = [(fgetKeyIdx_s1(it, keyn, ky, def_val, ler(it)), it = 1, SIZE(ky))]
-  IF(PRESENT(lerr)) lerr = ANY(ler)
-END FUNCTION fgetKeys
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!========== GET THE VALUE OF A KEY FROM A "keys_type" DERIVED TYPE ; THE RETURNED VALUE IS THE ERROR CODE        ==============
-!==========  The key "keyn" is searched in: 1)           "ky(:)%name" (if given)                                 ==============
-!==========                                 2)      "tracers(:)%name"                                            ==============
-!==========                                 3) "isotope%keys(:)%name"                                            ==============
-!==========  for the tracer[s] "tname[(:)]" (if given) or all the available tracers from the used set otherwise. ==============
-!==========  The type of the returned value(s) can be string, integer or real, scalar or vector                  ==============
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_s1(keyn, val, tname, ky) RESULT(lerr)
+  ler = itr <= 0 .OR. itr > SIZE(ky); IF(ler) RETURN
+  iky = strIdx(ky(itr)%key(:), keyn)
+  ler = iky == 0;                     IF(ler) RETURN
+  val = ky(itr)%val(iky)
+END SUBROUTINE getKeyIdx
+
+END FUNCTION fgetKeyIdx
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!===                                          GET KEYS VALUES FROM TRACERS INDICES                                          ===
+!==============================================================================================================================
+!=== TRY TO GET THE KEY NAMED "key" FOR THE "itr"th TRACER IN:                                                              ===
+!===  * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE:                                                                    ===
+!===  * IN INTERNAL TRACERS DATABASE "tracers(:)%keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")        ===
+!=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER:                                            ===
+!===  * A SCALAR                                                                                                            ===
+!===  * A VECTOR, WHICH IS THE FOUND VALUE PARSED WITH THE SEPARATOR ","                                                    ===
+!===                                                                                                                        ===
+!=== SYNTAX:       lerr = getKeyByIndex_{sirl}{1m}{1m}1(keyn[(:)], val[(:)], itr[, ky(:)]          [, def][, lDisp])        ===
+!==============================================================================================================================
+!=== IF "itr" IS NOT PRESENT, VALUES FOR ALL THE TRACERS OF THE SELECTED DATABASE ARE STORED IN THE VECTOR "val(:)"         ===
+!=== THE NAME OF THE TRACERS FOUND IN THE EFFECTIVELY USED DATABASE CAN BE RETURNED OPTIONALLY IN "nam(:)"                  ===
+!=== SYNTAX        lerr = getKeyByIndex_{sirl}{1m}mm   (keyn[(:)], val (:)      [, ky(:)][, nam(:)][, def][, lDisp])        ===
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_s111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
   CHARACTER(LEN=*),          INTENT(IN)  :: keyn
   CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
-  CHARACTER(LEN=*),          INTENT(IN)  :: tname
+  INTEGER,                   INTENT(IN)  :: itr
   TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: tnam
-  tnam = strHead(delPhase(tname),'_',.TRUE.)                                             !--- Remove phase and tag
-  IF(PRESENT(ky)) THEN                                                                   !=== KEY FROM "ky"
-               val = fgetKeyNam_s1(tname, keyn, ky,           lerr=lerr)                 !--- "ky" and "tname"
-    IF( lerr ) val = fgetKeyNam_s1(tnam,  keyn, ky,           lerr=lerr)                 !--- "ky" and "tnam"
-  ELSE
-    IF(         .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0    !=== KEY FROM "tracers"
-    IF(.NOT.lerr) THEN
-               val = fgetKeyNam_s1(tname, keyn, tracers%keys, lerr=lerr)                 !--- "ky" and "tname"
-      IF(lerr) val = fgetKeyNam_s1(tnam,  keyn, tracers%keys, lerr=lerr)                 !--- "ky" and "tnam"
-    END IF
-    IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0    !=== KEY FROM "isotope"
-    IF(.NOT.lerr) THEN
-               val = fgetKeyNam_s1(tname, keyn, isotope%keys, lerr=lerr)                 !--- "ky" and "tname"
-      IF(lerr) val = fgetKeyNam_s1(tnam,  keyn, isotope%keys, lerr=lerr)                 !--- "ky" and "tnam"
-    END IF
+  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_sm11([keyn], val, itr, ky, def, lDisp)
+END FUNCTION getKeyByIndex_s111
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_i111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
+  INTEGER,                   INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_im11([keyn], val, itr, ky, def, lDisp)
+END FUNCTION getKeyByIndex_i111
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_r111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
+  REAL   ,                   INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_rm11([keyn], val, itr, ky, def, lDisp)
+END FUNCTION getKeyByIndex_r111
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_l111(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
+  LOGICAL,                   INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_lm11([keyn], val, itr, ky, def, lDisp)
+END FUNCTION getKeyByIndex_l111
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_sm11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  LOGICAL :: lD
+  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" for tracer nr. '//TRIM(int2str(itr))
+  lerr = .TRUE.
+  IF(lerr .AND. PRESENT(ky))         val = fgetKey(ky)                                   !--- "ky"
+  IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)%keys)                      !--- "tracers"
+  IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                      !--- "isotope"
+  IF(lerr .AND. PRESENT(def)) THEN
+     val = def; lerr = .NOT.PRESENT(def)
+     CALL msg('Using defaut value of '//TRIM(s)//': '//TRIM(def), modname, lD)
   END IF
-END FUNCTION getKeyByName_s1
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_s1m(keyn, val, tname, ky) RESULT(lerr)
+  CALL msg('No '//TRIM(s)//' or out of bounds index', modname, lD .AND. lerr)
+
+CONTAINS
+
+CHARACTER(LEN=maxlen) FUNCTION fgetKey(ky) RESULT(val)
+  TYPE(keys_type),  INTENT(IN)  :: ky(:)
+  lerr = SIZE(ky) == 0; IF(lerr) RETURN
+  val = fgetKeyIdx(itr, keyn(:), ky, lerr)
+END FUNCTION fgetKey
+
+END FUNCTION getKeyByIndex_sm11
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_im11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  INTEGER,                   INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval, s
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2int(sval)
+  lerr = val == -HUGE(1)
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByIndex_im11
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_rm11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  REAL   ,                   INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval, s
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2real(sval)
+  lerr = val == -HUGE(1.)
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByIndex_rm11
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_lm11(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  LOGICAL,                   INTENT(OUT) :: val
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval, s
+  INTEGER               :: ival
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  ival = str2bool(sval)
+  lerr = ival == -1
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
+  IF(.NOT.lerr) val = ival == 1
+END FUNCTION getKeyByIndex_lm11
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_s1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
   CHARACTER(LEN=*),                   INTENT(IN)  :: keyn
   CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
-  CHARACTER(LEN=*),                   INTENT(IN)  :: tname
+  INTEGER,                            INTENT(IN)  :: itr
   TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval
+  lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, def, lDisp); IF(lerr) RETURN
+  lerr = strParse(sval, ',', val)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+END FUNCTION getKeyByIndex_s1m1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_i1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
+  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2int(svals)
+  lerr = ANY(val == -HUGE(1))
+  s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByIndex_i1m1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_r1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
+  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp)
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2real(svals)
+  lerr = ANY(val == -HUGE(1.))
+  s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByIndex_r1m1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_l1m1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
+  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  INTEGER,               ALLOCATABLE :: ivals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11([keyn], sval, itr, ky, lDisp=lDisp)
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  ivals = str2bool(svals)
+  lerr = ANY(ivals == -1)
+  s = 'key "'//TRIM(keyn)//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
+  IF(.NOT.lerr) val = ivals == 1
+END FUNCTION getKeyByIndex_l1m1
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_smm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                            INTENT(IN)  :: itr
+  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
 !------------------------------------------------------------------------------------------------------------------------------
   CHARACTER(LEN=maxlen) :: sval
-  lerr = getKeyByName_s1(keyn, sval, tname, ky)
-  IF(test(fmsg('missing key "'//TRIM(keyn)//'" for tracer "'//TRIM(tname)//'"', modname, lerr), lerr)) RETURN
+  lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, def, lDisp); IF(lerr) RETURN
   lerr = strParse(sval, ',', val)
-END FUNCTION getKeyByName_s1m
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_sm(keyn, val, tname, ky, nam) RESULT(lerr)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+END FUNCTION getKeyByIndex_smm1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_imm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2int(svals)
+  lerr = ANY(val == -HUGE(1))
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByIndex_imm1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_rmm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2real(svals)
+  lerr = ANY(val == -HUGE(1.))
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByIndex_rmm1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_lmm1(keyn, val, itr, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:)
+  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  INTEGER,                   INTENT(IN)  :: itr
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  INTEGER,               ALLOCATABLE :: ivals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_sm11(keyn, sval, itr, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  ivals = str2bool(svals)
+  lerr = ANY(ivals == -1)
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of tracer nr. '//TRIM(int2str(itr))//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
+  IF(.NOT.lerr) val = ivals == 1
+END FUNCTION getKeyByIndex_lmm1
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_s1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
   CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
   CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: val(:)
-  CHARACTER(LEN=*),                             INTENT(IN)  :: tname(:)
-  TYPE(keys_type),       OPTIONAL, TARGET,      INTENT(IN)  :: ky(:)
+  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
   CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  TYPE(keys_type), POINTER ::  keys(:)
-  LOGICAL :: lk, lt, li
-  INTEGER :: iq, nq
-
-  !--- DETERMINE THE DATABASE TO BE USED (ky, tracers or isotope)
-  lk = PRESENT(ky)
-  lt = .NOT.lk .AND. ALLOCATED(tracers);  IF(lt) lt = SIZE(tracers)  /= 0; IF(lt) lt = ANY(tracers(1)%keys%key(:) == keyn)
-  li = .NOT.lt .AND. ALLOCATED(isotopes); IF(li) li = SIZE(isotopes) /= 0; IF(li) li = ANY(isotope%keys(1)%key(:) == keyn)
-
-  !--- LINK "keys" TO THE RIGHT DATABASE
-  IF(test(.NOT.ANY([lk,lt,li]), lerr)) RETURN
-  IF(lk) keys => ky(:)
-  IF(lt) keys => tracers(:)%keys
-  IF(li) keys => isotope%keys(:)
-
-  !--- GET THE DATA
-  nq = SIZE(tname)
-  ALLOCATE(val(nq))
-  lerr = ANY([(getKeyByName_s1(keyn, val(iq), tname(iq), keys(:)), iq=1, nq)])
-  IF(PRESENT(nam)) nam = tname(:)
-
-END FUNCTION getKeyByName_sm
-!==============================================================================================================================
-LOGICAL FUNCTION getKey_sm(keyn, val, ky, nam) RESULT(lerr)
+  CHARACTER(LEN=*),      OPTIONAL,              INTENT(IN)  :: def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_smmm([keyn], val, ky, nam, def, lDisp)
+END FUNCTION getKeyByIndex_s1mm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_i1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
   CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
-  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: val(:)
-  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  :: ky(:)
+  INTEGER,                         ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
   CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-! Note: if names are repeated, getKeyByName_sm can't be used ; this routine, using indexes, must be used instead.
-  IF(PRESENT(ky)) THEN                                                                   !=== KEY FROM "ky"
-    val = fgetKeys(keyn, ky, lerr=lerr)
-    IF(PRESENT(nam)) nam = ky(:)%name
-  ELSE
-    IF(         .NOT.test(.NOT.ALLOCATED(tracers ), lerr)) lerr = SIZE(tracers ) == 0    !=== KEY FROM "tracers"
-    IF(.NOT.lerr) val = fgetKeys(keyn, tracers%keys, lerr=lerr)
-    IF(.NOT.lerr.AND.PRESENT(nam)) nam = tracers(:)%keys%name
-    IF(lerr.AND..NOT.test(.NOT.ALLOCATED(isotopes), lerr)) lerr = SIZE(isotopes) == 0    !=== KEY FROM "isotope"
-    IF(.NOT.lerr) val = fgetKeys(keyn, isotope%keys, lerr=lerr)
-    IF(.NOT.lerr.AND.PRESENT(nam)) nam = isotope%keys(:)%name
+  INTEGER,               OPTIONAL,              INTENT(IN)  :: def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_immm([keyn], val, ky, nam, def, lDisp)
+END FUNCTION getKeyByIndex_i1mm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_r1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
+  REAL,                            ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
+  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
+  REAL,                  OPTIONAL,              INTENT(IN)  :: def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_rmmm([keyn], val, ky, nam, def, lDisp)
+END FUNCTION getKeyByIndex_r1mm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_l1mm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
+  LOGICAL,                         ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::  ky(:)
+  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: nam(:)
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+  lerr = getKeyByIndex_lmmm([keyn], val, ky, nam, def, lDisp)
+END FUNCTION getKeyByIndex_l1mm
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_smmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
+  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) ::  val(:)
+  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
+  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
+  CHARACTER(LEN=*),      OPTIONAL,              INTENT(IN)  ::  def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tname(:)
+  INTEGER :: iq, nq(3), k
+  LOGICAL :: lD, l(3)
+  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'"'
+  lerr = .TRUE.
+  IF(PRESENT(ky)) THEN;                 val = fgetKey(ky)                                !--- "ky"
+  ELSE IF(ALLOCATED(tracers)) THEN;     val = fgetKey(tracers(:)%keys)                   !--- "tracers"
+     IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                   !--- "isotope"
   END IF
-END FUNCTION getKey_sm
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_i1(keyn, val, tname, ky) RESULT(lerr)
-  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
-  INTEGER,                   INTENT(OUT) :: val
-  CHARACTER(LEN=*),          INTENT(IN)  :: tname
-  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: sval
-  INTEGER :: ierr
-  lerr = getKeyByName_s1(keyn, sval, tname, ky)
-  IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
-  READ(sval, *, IOSTAT=ierr) val
-  IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, ierr/=0), lerr)) RETURN
-END FUNCTION getKeyByName_i1
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_i1m(keyn, val, tname, ky) RESULT(lerr)
-  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
-  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
-  CHARACTER(LEN=*),          INTENT(IN)  :: tname
-  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
-  INTEGER :: ierr, iq, nq
-  IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO
-  IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not an integer', modname, lerr), lerr)) RETURN
-END FUNCTION getKeyByName_i1m
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_im(keyn, val, tname, ky, nam) RESULT(lerr)
-  CHARACTER(LEN=*),                             INTENT(IN)  ::  keyn
-  INTEGER,                         ALLOCATABLE, INTENT(OUT) ::   val(:)
-  CHARACTER(LEN=*),                             INTENT(IN)  :: tname(:)
-  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::    ky(:)
-  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::   nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
-  INTEGER :: ierr, iq, nq
-  IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  DO iq = 1, nq                                                      !--- CONVERT THE KEYS TO INTEGERS
-    READ(sval(iq), *, IOSTAT=ierr) val(iq)
-    IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN
-  END DO
-  IF(PRESENT(nam)) nam = names(:)
-END FUNCTION getKeyByName_im
-!==============================================================================================================================
-LOGICAL FUNCTION getKey_im(keyn, val, ky, nam) RESULT(lerr)
-  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
+  IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF
+  IF(.NOT.PRESENT(def)) THEN; CALL msg('No '//TRIM(s)//' found', modname, lD); RETURN; END IF
+
+  !--- DEFAULT VALUE
+  l = [PRESENT(ky), ALLOCATED(tracers), ASSOCIATED(isotope)]; nq(:) = 0
+  IF(l(1)) nq(1) = SIZE(ky)
+  IF(l(2)) nq(2) = SIZE(tracers)
+  IF(l(3)) nq(3) = SIZE(isotope%keys)
+  DO k = 1, 3; IF(l(k) .AND. nq(k) /= 0) THEN; val = [(def, iq = 1, nq(k))]; EXIT; END IF; END DO
+  lerr = k == 4
+  CALL msg('Using defaut value for '//TRIM(s)//': '//TRIM(def), modname, lD .AND. .NOT.lerr)
+  CALL msg('No '//TRIM(s), modname, lD .AND. lerr)
+
+CONTAINS
+
+FUNCTION fgetKey(ky) RESULT(val)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)
+  TYPE(keys_type),       INTENT(IN)  :: ky(:)
+  LOGICAL :: ler(SIZE(ky))
+  INTEGER :: iq
+  lerr = SIZE(ky) == 0; IF(lerr) RETURN
+  tname = ky%name
+  val = [(fgetKeyIdx(iq, keyn(:), ky, ler(iq)), iq = 1, SIZE(ky))]
+  lerr = ANY(ler)
+END FUNCTION fgetKey
+
+END FUNCTION getKeyByIndex_smmm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_immm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
   INTEGER,                         ALLOCATABLE, INTENT(OUT) ::  val(:)
   TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
   CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
-  INTEGER :: ierr, iq, nq
-  IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  DO iq = 1, nq
-    READ(sval(iq), *, IOSTAT=ierr) val(iq)
-    IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not an integer', modname, ierr/=0), lerr)) RETURN
-  END DO
-  IF(PRESENT(nam)) nam = names
-END FUNCTION getKey_im
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_r1(keyn, val, tname, ky) RESULT(lerr)
-  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
-  REAL,                      INTENT(OUT) :: val
-  CHARACTER(LEN=*),          INTENT(IN)  :: tname
-  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: sval
-  INTEGER :: ierr
-  lerr = getKeyByName_s1(keyn, sval, tname, ky)
-  IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing',    modname, lerr), lerr)) RETURN
-  READ(sval, *, IOSTAT=ierr) val
-  IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a real', modname, ierr/=0), lerr)) RETURN
-END FUNCTION getKeyByName_r1
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_r1m(keyn, val, tname, ky) RESULT(lerr)
-  CHARACTER(LEN=*),           INTENT(IN)  :: keyn
-  REAL,          ALLOCATABLE, INTENT(OUT) :: val(:)
-  CHARACTER(LEN=*),           INTENT(IN)  :: tname
-  TYPE(keys_type),  OPTIONAL, INTENT(IN)  ::  ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
-  INTEGER :: ierr, iq, nq
-  IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  lerr = .FALSE.; DO iq=1, nq; READ(sval(iq), *, IOSTAT=ierr) val(iq); lerr = lerr .OR. ierr /= 0; END DO
-  IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(tname)//'" is not a vector of reals', modname, lerr), lerr)) RETURN
-END FUNCTION getKeyByName_r1m
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_rm(keyn, val, tname, ky, nam) RESULT(lerr)
-  CHARACTER(LEN=*),                             INTENT(IN)  ::  keyn
-  REAL,                            ALLOCATABLE, INTENT(OUT) ::   val(:)
-  CHARACTER(LEN=*),                             INTENT(IN)  :: tname(:)
-  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::    ky(:)
-  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::   nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
-  INTEGER :: ierr, iq, nq
-  IF(test(getKeyByName_sm(keyn, sval, tname, ky, names), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  DO iq = 1, nq                                                      !--- CONVERT THE KEYS TO INTEGERS
-    READ(sval(iq), *, IOSTAT=ierr) val(iq)
-    IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN
-  END DO
-  IF(PRESENT(nam)) nam = names
-END FUNCTION getKeyByName_rm
-!==============================================================================================================================
-LOGICAL FUNCTION getKey_rm(keyn, val, ky, nam) RESULT(lerr)
-  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
+  INTEGER,               OPTIONAL,              INTENT(IN)  ::  def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:)
+  LOGICAL,               ALLOCATABLE ::    ll(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2int(svals)
+  ll = val == -HUGE(1)
+  lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(strStack(svals, MASK=ll)), modname, lerr)
+  IF(.NOT.lerr .AND. PRESENT(nam)) nam = tname
+END FUNCTION getKeyByIndex_immm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_rmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
   REAL,                            ALLOCATABLE, INTENT(OUT) ::  val(:)
   TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
   CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:), names(:)
-  INTEGER :: ierr, iq, nq
-  IF(test(getKey_sm(keyn, sval, ky, names), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  DO iq = 1, nq                                                      !--- CONVERT THE KEYS TO INTEGERS
-    READ(sval(iq), *, IOSTAT=ierr) val(iq)
-    IF(test(fmsg('key "'//TRIM(keyn)//'" of tracer "'//TRIM(names(iq))//'" is not a real', modname, ierr/=0), lerr)) RETURN
-  END DO
-  IF(PRESENT(nam)) nam = names
-END FUNCTION getKey_rm
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_l1(keyn, val, tname, ky) RESULT(lerr)
-  USE strings_mod, ONLY: str2bool
-  CHARACTER(LEN=*),          INTENT(IN)  :: keyn
-  LOGICAL,                   INTENT(OUT) :: val
-  CHARACTER(LEN=*),          INTENT(IN)  :: tname
-  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: sval
-  lerr = getKeyByName_s1(keyn, sval, tname, ky)
-  IF(test(fmsg('key "'//TRIM(keyn)//'" or tracer "'//TRIM(tname)//'" is missing', modname, lerr), lerr)) RETURN
-  val = str2bool(sval)
-END FUNCTION getKeyByName_l1
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_l1m(keyn, val, tname, ky) RESULT(lerr)
-  USE strings_mod, ONLY: str2bool
-  CHARACTER(LEN=*),           INTENT(IN)  :: keyn
-  LOGICAL,       ALLOCATABLE, INTENT(OUT) :: val(:)
-  CHARACTER(LEN=*),           INTENT(IN)  :: tname
-  TYPE(keys_type),  OPTIONAL, INTENT(IN)  ::  ky(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
-  INTEGER :: iq, nq
-  IF(test(getKeyByName_s1m(keyn, sval, tname, ky), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
-END FUNCTION getKeyByName_l1m
-!==============================================================================================================================
-LOGICAL FUNCTION getKeyByName_lm(keyn, val, tname, ky, nam) RESULT(lerr)
-  USE strings_mod, ONLY: str2bool
-  CHARACTER(LEN=*),                             INTENT(IN)  ::  keyn
-  LOGICAL,                         ALLOCATABLE, INTENT(OUT) ::   val(:)
-  CHARACTER(LEN=*),                             INTENT(IN)  :: tname(:)
-  TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::    ky(:)
-  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::   nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
-  INTEGER :: iq, nq
-  IF(test(getKeyByName_sm(keyn, sval, tname, ky, nam), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
-END FUNCTION getKeyByName_lm
-!==============================================================================================================================
-LOGICAL FUNCTION getKey_lm(keyn, val, ky, nam) RESULT(lerr)
-  USE strings_mod, ONLY: str2bool
-  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn
+  REAL,                  OPTIONAL,              INTENT(IN)  ::  def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:)
+  LOGICAL,               ALLOCATABLE ::    ll(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2real(svals)
+  ll = val == -HUGE(1.)
+  lerr = ANY(ll); IF(.NOT.lerr) THEN; IF(PRESENT(nam)) nam = tname; RETURN; END IF
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(PACK(tname, MASK=ll)))//' is not a'
+  CALL msg(TRIM(s)//' a real: '//TRIM(strStack(svals, MASK=ll)), modname)
+END FUNCTION getKeyByIndex_rmmm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByIndex_lmmm(keyn, val, ky, nam, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                             INTENT(IN)  :: keyn(:)
   LOGICAL,                         ALLOCATABLE, INTENT(OUT) ::  val(:)
   TYPE(keys_type),       OPTIONAL,              INTENT(IN)  ::   ky(:)
   CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) ::  nam(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: sval(:)
+  LOGICAL,               OPTIONAL,              INTENT(IN)  ::  def
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:), tname(:)
+  LOGICAL,               ALLOCATABLE ::    ll(:)
+  INTEGER,               ALLOCATABLE :: ivals(:)
+  IF(     PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByIndex_smmm(keyn, svals, ky, tname, lDisp=lDisp)
+  IF(lerr) RETURN
+  ivals = str2bool(svals)
+  ll = ivals == -1
+  lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; IF(PRESENT(nam)) nam = tname; RETURN; END IF
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(strStack(svals, MASK=ll)), modname)
+END FUNCTION getKeyByIndex_lmmm
+!==============================================================================================================================
+
+
+
+!==============================================================================================================================
+!===                                           GET KEYS VALUES FROM TRACERS NAMES                                           ===
+!==============================================================================================================================
+!=== TRY TO GET THE KEY NAMED "key" FOR THE TRACER NAMED "tname" IN:                                                        ===
+!===  * ARGUMENT "ky" DATABASE IF SPECIFIED ; OTHERWISE:                                                                    ===
+!===  * IN INTERNAL TRACERS DATABASE "tracers(:)%keys" (IF UNFOUND, IN INTERNAL ISOTOPES DATABASE "isotope%keys(:)")        ===
+!=== THE RETURNED VALUE (STRING, AN INTEGER, A REAL OR A LOGICAL) CAN BE EITHER:                                            ===
+!===  * A SCALAR                                                                                                            ===
+!===  * A VECTOR, WHICH IS THE FOUND VALUE PARSED WITH THE SEPARATOR ","                                                    ===
+!===                                                                                                                        ===
+!=== SYNTAX:       lerr = getKeyByName_{sirl}{1m}{1m}1(keyn[(:)], val[(:)], tname  [, ky(:)][, def][, lDisp])               ===
+!==============================================================================================================================
+!=== IF "tname(:)" IS A VECTOR, THE RETURNED VALUES (ONE EACH "tname(:)" ELEMENT) ARE STORED IN THE VECTOR "val(:)"         ===
+!===                                                                                                                        ===
+!=== SYNTAX        lerr = getKeyByName_{sirl}{1m}mm   (keyn[(:)], val (:), tname(:)[, ky(:)][, def][, lDisp])               ===
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_s111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_sm11([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_s111
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_i111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  INTEGER,                   INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_im11([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_i111
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_r111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  REAL   ,                   INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_rm11([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_r111
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_l111(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  LOGICAL,                   INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_lm11([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_l111
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_sm11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  CHARACTER(LEN=maxlen),     INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s, tnam
+  LOGICAL :: lD
+  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" for "'//TRIM(tname)//'"'
+  lerr = .TRUE.
+  tnam = strHead(delPhase(tname),'_',.TRUE.)                                             !--- Remove phase and tag
+  IF(lerr .AND. PRESENT(ky))         val = fgetKey(ky)                                   !--- "ky"
+  IF(lerr .AND. ALLOCATED (tracers)) val = fgetKey(tracers(:)%keys)                      !--- "tracers"
+  IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                      !--- "isotope"
+  IF(lerr .AND. PRESENT(def)) THEN
+     val = def; lerr = .NOT.PRESENT(def)
+     CALL msg('Using defaut value of '//TRIM(s)//': '//TRIM(def), modname, lD)
+  END IF
+  CALL msg('No '//TRIM(s)//' or out of bounds index', modname, lD .AND. lerr)
+
+CONTAINS
+
+ CHARACTER(LEN=maxlen) FUNCTION fgetKey(ky) RESULT(val)
+  TYPE(keys_type),  INTENT(IN)  :: ky(:)
+  lerr = SIZE(ky) == 0
+  IF(lerr) RETURN
+           val = fgetKeyIdx(strIdx(ky%name, tname), [keyn], ky, lerr)
+  IF(lerr) val = fgetKeyIdx(strIdx(ky%name, tnam ), [keyn], ky, lerr)
+
+END FUNCTION fgetKey
+
+END FUNCTION getKeyByName_sm11
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_im11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  INTEGER,                   INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval, s
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2int(sval)
+  lerr = val == -HUGE(1)
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByName_im11
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_rm11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  REAL   ,                   INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval, s
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2real(sval)
+  lerr = val == -HUGE(1.)
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByName_rm11
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_lm11(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  LOGICAL,                   INTENT(OUT) :: val
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval, s
+  INTEGER               :: ival
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  ival = str2bool(sval)
+  lerr = ival == -1
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
+  IF(.NOT.lerr) val = ival == 1
+END FUNCTION getKeyByName_lm11
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_s1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn, tname
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval
+  lerr = getKeyByName_sm11([keyn], sval, tname, ky, def, lDisp); IF(lerr) RETURN
+  lerr = strParse(sval, ',', val)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+END FUNCTION getKeyByName_s1m1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_i1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2int(svals)
+  lerr = ANY(val == -HUGE(1))
+  s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByName_i1m1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_r1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2real(svals)
+  lerr = ANY(val == -HUGE(1.))
+  s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByName_r1m1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_l1m1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname
+  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  INTEGER,               ALLOCATABLE :: ivals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11([keyn], sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  ivals = str2bool(svals)
+  lerr = ANY(ivals == -1)
+  s = 'key "'//TRIM(keyn)//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
+  IF(.NOT.lerr) val = ivals == 1
+END FUNCTION getKeyByName_l1m1
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_smm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn(:), tname
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type),          OPTIONAL, INTENT(IN)  :: ky(:)
+  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,                  OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: sval
+  lerr = getKeyByName_sm11(keyn, sval, tname, ky, def, lDisp); IF(lerr) RETURN
+  lerr = strParse(sval, ',', val)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+END FUNCTION getKeyByName_smm1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_imm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2int(svals)
+  lerr = ANY(val == -HUGE(1))
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByName_imm1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_rmm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  val = str2real(svals)
+  lerr = ANY(val == -HUGE(1.))
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(sval), modname, lerr)
+END FUNCTION getKeyByName_rmm1
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_lmm1(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname
+  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  :: ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: sval, s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  INTEGER,               ALLOCATABLE :: ivals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_sm11(keyn, sval, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  lerr = strParse(sval, ',', svals)
+  IF(fmsg('can''t parse '//TRIM(sval), modname, lerr)) RETURN
+  ivals = str2bool(svals)
+  lerr = ANY(ivals == -1)
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(tname)//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(sval), modname, lerr)
+  IF(.NOT.lerr) val = ivals == 1
+END FUNCTION getKeyByName_lmm1
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_s1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn, tname(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type),       OPTIONAL,    INTENT(IN)  ::  ky(:)
+  CHARACTER(LEN=*),      OPTIONAL,    INTENT(IN)  :: def
+  LOGICAL,               OPTIONAL,    INTENT(IN)  :: lDisp
+  lerr = getKeyByName_smmm([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_s1mm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_i1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname(:)
+  INTEGER,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_immm([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_i1mm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_r1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname(:)
+  REAL,         ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_rmmm([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_r1mm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_l1mm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn, tname(:)
+  LOGICAL,      ALLOCATABLE, INTENT(OUT) :: val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::  ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+  lerr = getKeyByName_lmmm([keyn], val, tname, ky, def, lDisp)
+END FUNCTION getKeyByName_l1mm
+!==============================================================================================================================
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_smmm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),                   INTENT(IN)  :: keyn(:), tname(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) ::  val(:)
+  TYPE(keys_type),       OPTIONAL,    INTENT(IN)  ::   ky(:)
+  CHARACTER(LEN=*),      OPTIONAL,    INTENT(IN)  ::   def
+  LOGICAL,               OPTIONAL,    INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
   INTEGER :: iq, nq
-  IF(test(getKey_sm(keyn, sval, ky, nam), lerr)) RETURN
-  nq = SIZE(sval); ALLOCATE(val(nq))
-  lerr = .FALSE.; DO iq=1, nq; val(iq)=str2bool(sval(iq)); END DO
-END FUNCTION getKey_lm
+  LOGICAL :: lD
+  nq = SIZE(tname); ALLOCATE(val(nq))
+  lD = .TRUE.; IF(PRESENT(lDisp)) lD = lDisp
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'"'
+  lerr = .TRUE.
+  IF(PRESENT(ky)) THEN;                 val = fgetKey(ky)                                !--- "ky"
+  ELSE IF(ALLOCATED(tracers)) THEN;     val = fgetKey(tracers(:)%keys)                   !--- "tracers"
+     IF(lerr .AND. ASSOCIATED(isotope)) val = fgetKey(isotope%keys(:))                   !--- "isotope"
+  END IF
+  IF(.NOT.PRESENT(def)) THEN; CALL msg('No '//TRIM(s)//' found', modname, lD); RETURN; END IF
+
+  !--- DEFAULT VALUE
+  val = [(def, iq = 1, SIZE(tname))]
+  CALL msg('Using defaut value for '//TRIM(s)//': '//TRIM(def), modname, lD)
+
+CONTAINS
+
+FUNCTION fgetKey(ky) RESULT(val)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)
+  TYPE(keys_type),       INTENT(IN)  :: ky(:)
+  LOGICAL,               ALLOCATABLE :: ler(:)
+  lerr = SIZE(ky) == 0; IF(lerr) RETURN
+  ALLOCATE(ler(SIZE(tname)))
+  val = [(fgetKeyIdx(strIdx(ky(:)%name, tname(iq)), keyn, ky, ler(iq)), iq = 1, SIZE(tname))]
+  lerr = ANY(ler)
+END FUNCTION fgetKey
+
+END FUNCTION getKeyByName_smmm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_immm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname(:)
+  INTEGER,      ALLOCATABLE, INTENT(OUT) ::  val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::   ky(:)
+  INTEGER,         OPTIONAL, INTENT(IN)  ::  def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  LOGICAL,               ALLOCATABLE ::    ll(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, int2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2int(svals)
+  ll = val == -HUGE(1)
+  lerr = ANY(ll); IF(.NOT.lerr) RETURN
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
+  CALL msg(TRIM(s)//' an integer: '//TRIM(strStack(svals, MASK=ll)), modname)
+END FUNCTION getKeyByName_immm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_rmmm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname(:)
+  REAL,         ALLOCATABLE, INTENT(OUT) ::  val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::   ky(:)
+  REAL,            OPTIONAL, INTENT(IN)  ::  def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  LOGICAL,               ALLOCATABLE ::    ll(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, real2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  val = str2real(svals)
+  ll = val == -HUGE(1.)
+  lerr = ANY(ll); IF(.NOT.lerr) RETURN
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
+  CALL msg(TRIM(s)//' a real: '//TRIM(strStack(svals, MASK=ll)), modname)
+END FUNCTION getKeyByName_rmmm
+!==============================================================================================================================
+LOGICAL FUNCTION getKeyByName_lmmm(keyn, val, tname, ky, def, lDisp) RESULT(lerr)
+  CHARACTER(LEN=*),          INTENT(IN)  :: keyn(:), tname(:)
+  LOGICAL,      ALLOCATABLE, INTENT(OUT) ::  val(:)
+  TYPE(keys_type), OPTIONAL, INTENT(IN)  ::   ky(:)
+  LOGICAL,         OPTIONAL, INTENT(IN)  ::  def
+  LOGICAL,         OPTIONAL, INTENT(IN)  :: lDisp
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: s
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: svals(:)
+  LOGICAL,               ALLOCATABLE ::    ll(:)
+  INTEGER,               ALLOCATABLE :: ivals(:)
+  IF(     PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, bool2str(def), lDisp)
+  IF(.NOT.PRESENT(def)) lerr = getKeyByName_smmm(keyn, svals, tname, ky, lDisp=lDisp)
+  IF(lerr) RETURN
+  ivals = str2bool(svals)
+  ll = ivals == -1
+  lerr = ANY(ll); IF(.NOT.lerr) THEN; val = ivals == 1; RETURN; END IF
+  s = 'key "'//TRIM(strStack(keyn, '/'))//'" of '//TRIM(strStack(tname, MASK=ll))//' is not'
+  CALL msg(TRIM(s)//' a boolean: '//TRIM(strStack(svals, MASK=ll)), modname)
+END FUNCTION getKeyByName_lmmm
 !==============================================================================================================================
 
@@ -1808 +2596 @@
   IF(.NOT.PRESENT(phases)) out = [( addPhase_i1(s(k), ipha, known_phases), k=1, SIZE(s) )]
 END FUNCTION addPhase_im
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== APPEND TRACERS DATABASE "tracs" WITH TRACERS/KEYS "tname"/"keys" ; SAME FOR INTERNAL DATABASE "tracers" ==================
+!==============================================================================================================================
+LOGICAL FUNCTION addTracer_1(tname, keys, tracs) RESULT(lerr)
+  CHARACTER(LEN=*),             INTENT(IN)    :: tname
+  TYPE(keys_type),              INTENT(IN)    ::  keys
+  TYPE(trac_type), ALLOCATABLE, INTENT(INOUT) :: tracs(:)
+  TYPE(trac_type), ALLOCATABLE :: tr(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
+  INTEGER :: nt, ix
+  IF(ALLOCATED(tracs)) THEN
+     lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN
+     nt = SIZE(tracs)
+     ix = strIdx(tnames, tname)
+     CALL msg('Modifying existing tracer "'//TRIM(tname)//'"', modname, ix /= 0)
+     CALL msg('Appending with tracer "'    //TRIM(tname)//'"', modname, ix == 0)
+     IF(ix == 0) THEN
+        ix = nt+1; ALLOCATE(tr(nt+1)); tr(1:nt) = tracs(1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs)
+     END IF
+  ELSE
+     CALL msg('Creating a tracer descriptor with tracer "'//TRIM(tname)//'"', modname)
+     ix = 1; ALLOCATE(tracs(1))
+  END IF
+  CALL addKey('name', tname, tracs(ix)%keys)
+  tracs(ix)%name = tname
+  tracs(ix)%keys = keys
+
+END FUNCTION addTracer_1
+!==============================================================================================================================
+LOGICAL FUNCTION addTracer_1def(tname, keys) RESULT(lerr)
+  CHARACTER(LEN=*),             INTENT(IN)    :: tname
+  TYPE(keys_type),              INTENT(IN)    ::  keys
+  lerr = addTracer_1(tname, keys, tracers)
+END FUNCTION addTracer_1def
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+LOGICAL FUNCTION delTracer_1(tname, tracs) RESULT(lerr)
+  CHARACTER(LEN=*),                     INTENT(IN)    :: tname
+  TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: tracs(:)
+  TYPE(trac_type), ALLOCATABLE :: tr(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: tnames(:)
+  INTEGER :: nt, ix
+  lerr = .NOT.ALLOCATED(tracs)
+  IF(fmsg('Can''t remove tracer "'//TRIM(tname)//'" from an empty tracers descriptor', modname, lerr)) RETURN
+  nt = SIZE(tracs)
+  lerr = getKey('name', tnames, ky=tracs(:)%keys); IF(lerr) RETURN
+  ix = strIdx(tnames, tname)
+  CALL msg('Removing tracer "'             //TRIM(tname)//'"', modname, ix /= 0)
+  CALL msg('Can''t remove unknown tracer "'//TRIM(tname)//'"', modname, ix == 0)
+  IF(ix /= 0) THEN
+     ALLOCATE(tr(nt-1)); tr(1:ix-1) = tracs(1:ix-1); tr(ix:nt-1) = tracs(ix+1:nt); CALL MOVE_ALLOC(FROM=tr, TO=tracs)
+  END IF
+END FUNCTION delTracer_1
+!==============================================================================================================================
+LOGICAL FUNCTION delTracer_1def(tname) RESULT(lerr)
+  CHARACTER(LEN=*), INTENT(IN) :: tname
+  lerr = delTracer(tname, tracers)
+END FUNCTION delTracer_1def
 !==============================================================================================================================
 
@@ -1908 +2759 @@
 !==============================================================================================================================
 
-
-!==============================================================================================================================
-!=== GET THE NAME(S) OF THE ANCESTOR(S) OF TRACER(S) "tname" AT GENERATION "igen"  IN THE TRACERS DESCRIPTORS LIST "tr" =======
-!==============================================================================================================================
-SUBROUTINE ancestor_1(t, out, tname, igen)
-  TYPE(trac_type),       INTENT(IN)  :: t(:)
-  CHARACTER(LEN=maxlen), INTENT(OUT) :: out
-  CHARACTER(LEN=*),      INTENT(IN)  :: tname
-  INTEGER,     OPTIONAL, INTENT(IN)  :: igen
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ix
-  CALL idxAncestor_1(t, ix, tname, igen)
-  out = ''; IF(ix /= 0) out = t(ix)%name
-END SUBROUTINE ancestor_1
-!==============================================================================================================================
-SUBROUTINE ancestor_mt(t, out, tname, igen)
-  TYPE(trac_type),       INTENT(IN)  :: t(:)
-  CHARACTER(LEN=*),      INTENT(IN)  :: tname(:)
-  CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(tname))
-  INTEGER,     OPTIONAL, INTENT(IN)  :: igen
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ix(SIZE(tname))
-  CALL idxAncestor_mt(t, ix, tname, igen)
-  out(:) = ''; WHERE(ix /= 0) out = t(ix)%name
-END SUBROUTINE ancestor_mt
-!==============================================================================================================================
-SUBROUTINE ancestor_m(t, out, igen)
-  TYPE(trac_type),       INTENT(IN)  :: t(:)
-  CHARACTER(LEN=maxlen), INTENT(OUT) :: out(SIZE(t))
-  INTEGER,     OPTIONAL, INTENT(IN)  :: igen
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ix(SIZE(t))
-  CALL idxAncestor_m(t, ix, igen)
-  out(:) = ''; WHERE(ix /= 0) out = t(ix)%name
-END SUBROUTINE ancestor_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== GET THE INDEX(ES) OF THE GENERATION "igen" ANCESTOR(S) OF "tname" (t%name IF UNSPECIFIED) IN THE "t" LIST ================
-!==============================================================================================================================
-SUBROUTINE idxAncestor_1(t, idx, tname, igen)
-  TYPE(trac_type),   INTENT(IN)  :: t(:)
-  INTEGER,           INTENT(OUT) :: idx
-  CHARACTER(LEN=*),  INTENT(IN)  :: tname
-  INTEGER, OPTIONAL, INTENT(IN)  :: igen
-  INTEGER :: ig
-  ig = 0; IF(PRESENT(igen)) ig = igen
-  idx = strIdx(t(:)%name, tname)
-  IF(idx == 0)                 RETURN            !--- Tracer not found
-  IF(t(idx)%iGeneration <= ig) RETURN            !--- Tracer has a lower generation number than asked generation 'igen"
-  DO WHILE(t(idx)%iGeneration > ig); idx = strIdx(t(:)%name, t(idx)%parent); END DO
-END SUBROUTINE idxAncestor_1
-!------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE idxAncestor_mt(t, idx, tname, igen)
-  TYPE(trac_type),   INTENT(IN)  :: t(:)
-  CHARACTER(LEN=*),  INTENT(IN)  :: tname(:)
-  INTEGER,           INTENT(OUT) :: idx(SIZE(tname))
-  INTEGER, OPTIONAL, INTENT(IN)  :: igen
-  INTEGER :: ix
-  DO ix = 1, SIZE(tname); CALL idxAncestor_1(t, idx(ix), tname(ix), igen); END DO
-END SUBROUTINE idxAncestor_mt
-!------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE idxAncestor_m(t, idx, igen)
-  TYPE(trac_type),   INTENT(IN)  :: t(:)
-  INTEGER,           INTENT(OUT) :: idx(SIZE(t))
-  INTEGER, OPTIONAL, INTENT(IN)  :: igen
-  INTEGER :: ix
-  DO ix = 1, SIZE(t); CALL idxAncestor_1(t, idx(ix), t(ix)%name, igen); END DO
-END SUBROUTINE idxAncestor_m
-!==============================================================================================================================
-
-
 END MODULE readTracFiles_mod

LMDZ6/branches/cirrus/libf/misc/strings_mod.F90

@@ -10 +10 @@
   PUBLIC :: is_numeric, bool2str, int2str, real2str, dble2str
   PUBLIC :: reduceExpr, str2bool, str2int, str2real, str2dble
-  PUBLIC :: addQuotes, checkList, removeComment, test
+  PUBLIC :: addQuotes, checkList, removeComment
 
   INTERFACE get_in;     MODULE PROCEDURE getin_s,  getin_i,  getin_r,  getin_l;  END INTERFACE get_in
@@ -22 +22 @@
   INTERFACE strCount;   MODULE PROCEDURE  strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount
   INTERFACE strReplace; MODULE PROCEDURE strReplace_1,             strReplace_m; END INTERFACE strReplace
-  INTERFACE cat;        MODULE PROCEDURE   horzcat_s1,  horzcat_i1,  horzcat_r1, &
-!                 horzcat_d1,  horzcat_dm,
-                                           horzcat_sm,  horzcat_im,  horzcat_rm; END INTERFACE cat
-  INTERFACE find;         MODULE PROCEDURE    strFind,    find_int,    find_boo; END INTERFACE find
+  INTERFACE cat;        MODULE PROCEDURE  horzcat_s00, horzcat_i00, horzcat_r00,  & !horzcat_d00, &
+                                          horzcat_s10, horzcat_i10, horzcat_r10,  & !horzcat_d10, &
+                                          horzcat_s11, horzcat_i11, horzcat_r11,  & !horzcat_d11, &
+                                          horzcat_s21, horzcat_i21, horzcat_r21; END INTERFACE cat !horzcat_d21
+  INTERFACE strFind;      MODULE PROCEDURE strFind_1, strFind_m;                 END INTERFACE strFind
+  INTERFACE find;         MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find
   INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers
   INTERFACE reduceExpr;   MODULE PROCEDURE   reduceExpr_1,   reduceExpr_m; END INTERFACE reduceExpr
@@ -36 +38 @@
 CONTAINS
 
-!==============================================================================================================================
-LOGICAL FUNCTION test(lcond, lout) RESULT(lerr)
-  LOGICAL, INTENT(IN)  :: lcond
-  LOGICAL, INTENT(OUT) :: lout
-  lerr = lcond; lout = lcond
-END FUNCTION test
-!==============================================================================================================================
-
 
 !==============================================================================================================================
 SUBROUTINE init_printout(lunout_, prt_level_)
+  IMPLICIT NONE
   INTEGER, INTENT(IN) :: lunout_, prt_level_
   lunout    = lunout_
@@ -58 +53 @@
 !==============================================================================================================================
 SUBROUTINE getin_s(nam, val, def)
-USE ioipsl_getincom, ONLY: getin
+  USE ioipsl_getincom, ONLY: getin
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN)    :: nam
   CHARACTER(LEN=*), INTENT(INOUT) :: val
@@ -67 +63 @@
 !==============================================================================================================================
 SUBROUTINE getin_i(nam, val, def)
-USE ioipsl_getincom, ONLY: getin
+  USE ioipsl_getincom, ONLY: getin
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN)    :: nam
   INTEGER,          INTENT(INOUT) :: val
@@ -76 +73 @@
 !==============================================================================================================================
 SUBROUTINE getin_r(nam, val, def)
-USE ioipsl_getincom, ONLY: getin
+  USE ioipsl_getincom, ONLY: getin
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN)    :: nam
   REAL,             INTENT(INOUT) :: val
@@ -85 +83 @@
 !==============================================================================================================================
 SUBROUTINE getin_l(nam, val, def)
-USE ioipsl_getincom, ONLY: getin
+  USE ioipsl_getincom, ONLY: getin
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN)    :: nam
   LOGICAL,          INTENT(INOUT) :: val
@@ -99 +98 @@
 !==============================================================================================================================
 SUBROUTINE msg_1(str, modname, ll, unit)
+  IMPLICIT NONE
   !--- Display a simple message "str". Optional parameters:
   !    * "modname": module name, displayed in front of the message (with ": " separator) if present.
@@ -118 +118 @@
 !==============================================================================================================================
 SUBROUTINE msg_m(str, modname, ll, unit, nmax)
+  IMPLICIT NONE
   !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines.
   CHARACTER(LEN=*),           INTENT(IN) :: str(:)
@@ -138 +139 @@
 !==============================================================================================================================
 LOGICAL FUNCTION fmsg_1(str, modname, ll, unit) RESULT(l)
+  IMPLICIT NONE
   CHARACTER(LEN=*),           INTENT(IN) :: str
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
@@ -152 +154 @@
 !==============================================================================================================================
 LOGICAL FUNCTION fmsg_m(str, modname, ll, unit, nmax) RESULT(l)
+  IMPLICIT NONE
   CHARACTER(LEN=*),           INTENT(IN)  :: str(:)
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
@@ -173 +176 @@
 !==============================================================================================================================
 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   INTEGER :: k
@@ -182 +186 @@
 !==============================================================================================================================
 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   INTEGER :: k
@@ -199 +204 @@
 !==============================================================================================================================
 CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*),           INTENT(IN) :: str
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
@@ -214 +220 @@
 !==============================================================================================================================
 FUNCTION strHead_m(str, sep, lBackward) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
   CHARACTER(LEN=*),           INTENT(IN) :: str(:)
@@ -235 +242 @@
 !==============================================================================================================================
 CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*),           INTENT(IN) :: str
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
@@ -250 +258 @@
 !==============================================================================================================================
 FUNCTION strTail_m(str, sep, lBackWard) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
   CHARACTER(LEN=*),           INTENT(IN) :: str(:)
@@ -271 +280 @@
 !==============================================================================================================================
 FUNCTION strStack(str, sep, mask) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=:),          ALLOCATABLE :: out
   CHARACTER(LEN=*),           INTENT(IN) :: str(:)
@@ -292 +302 @@
 !==============================================================================================================================
 FUNCTION strStackm(str, sep, nmax) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
   CHARACTER(LEN=*),           INTENT(IN) :: str(:)
@@ -324 +335 @@
 !==============================================================================================================================
 SUBROUTINE strClean_1(str)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(INOUT) :: str
   INTEGER :: k, n, m
@@ -337 +349 @@
 !==============================================================================================================================
 SUBROUTINE strClean_m(str)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(INOUT) :: str(:)
   INTEGER :: k
@@ -349 +362 @@
 !==============================================================================================================================
 SUBROUTINE strReduce_1(str, nb)
+  IMPLICIT NONE
   CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str(:)
   INTEGER,          OPTIONAL,    INTENT(OUT)   :: nb
@@ -366 +380 @@
 !==============================================================================================================================
 SUBROUTINE strReduce_2(str1, str2)
+  IMPLICIT NONE
   CHARACTER(LEN=*),   ALLOCATABLE, INTENT(INOUT) :: str1(:)
   CHARACTER(LEN=*),                INTENT(IN)    :: str2(:)
@@ -392 +407 @@
 !==============================================================================================================================
 INTEGER FUNCTION strIdx_1(str, s) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str(:), s
   DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO
@@ -398 +414 @@
 !==============================================================================================================================
 FUNCTION strIdx_m(str, s, n) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
   INTEGER, OPTIONAL, INTENT(OUT) :: n
@@ -412 +429 @@
 !=== GET THE INDEX LIST OF THE ELEMENTS OF "str(:)" EQUAL TO "s" AND OPTIONALY, ITS LENGTH "n" ================================
 !==============================================================================================================================
-FUNCTION strFind(str, s, n) RESULT(out)
+FUNCTION strFind_1(str, s, n) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s
   INTEGER, OPTIONAL, INTENT(OUT) :: n
@@ -420 +438 @@
   out = PACK( [(k, k=1, SIZE(str(:), DIM=1))], MASK = str(:) == s )
   IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION strFind
-!==============================================================================================================================
-FUNCTION find_int(i,j,n) RESULT(out)
+END FUNCTION strFind_1
+!==============================================================================================================================
+FUNCTION strFind_m(str, s, n) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = [(strFind_1(str, s(k)), k=1, SIZE(s))]
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION strFind_m
+!==============================================================================================================================
+FUNCTION intFind_1(i,j,n) RESULT(out)
+  IMPLICIT NONE
   INTEGER,           INTENT(IN)  :: i(:), j
   INTEGER, OPTIONAL, INTENT(OUT) :: n
@@ -430 +460 @@
   out = PACK( [(k, k=1, SIZE(i(:), DIM=1))], MASK = i(:) == j )
   IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION find_int
-!==============================================================================================================================
-FUNCTION find_boo(l,n) RESULT(out)
-  LOGICAL,           INTENT(IN)  :: l(:)
+END FUNCTION intFind_1
+!==============================================================================================================================
+FUNCTION intFind_m(i,j,n) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN)  :: i(:), j(:)
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = [(intFind_1(i, j(k)), k=1, SIZE(j))]
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION intFind_m
+!==============================================================================================================================
+FUNCTION booFind(l,n) RESULT(out)
+   IMPLICIT NONE
+ LOGICAL,           INTENT(IN)  :: l(:)
   INTEGER, OPTIONAL, INTENT(OUT) :: n
   INTEGER,           ALLOCATABLE :: out(:)
@@ -440 +482 @@
   out = PACK( [(k, k=1, SIZE(l(:), DIM=1))], MASK = l(:) )
   IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION find_boo
+END FUNCTION booFind
 !==============================================================================================================================
 
@@ -450 +492 @@
 !==============================================================================================================================
 LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(IN)  :: rawList                          !--- String in which delimiters have to be identified
   CHARACTER(LEN=*),  INTENT(IN)  :: del(:)                           !--- List of delimiters
@@ -469 +512 @@
   END IF
 
-  IF(test(idx == 1 .AND. INDEX('+-',del(idel)) /= 0, lerr)) RETURN   !--- The front delimiter is different from +/-: error
-  IF(     idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1)))   RETURN   !--- The input string head is a valid number
+  lerr = idx == 1 .AND. INDEX('+-',del(idel)) /= 0; IF(lerr) RETURN  !--- The front delimiter is different from +/-: error
+  IF(    idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1)))     RETURN  !--- The input string head is a valid number
 
   !=== The string part in front of the 1st delimiter is not a valid number: search for next delimiter index "idx"
@@ -503 +546 @@
 !==============================================================================================================================
 LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(IN)  :: rawList
   CHARACTER(LEN=*),  INTENT(IN)  :: delimiter
@@ -514 +558 @@
 !==============================================================================================================================
 LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),     INTENT(IN)  :: rawList(:)
   CHARACTER(LEN=*),     INTENT(IN)  :: delimiter
@@ -530 +575 @@
 !==============================================================================================================================
 LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(IN)  :: rawList
   CHARACTER(LEN=*),  INTENT(IN)  :: delimiter(:)
@@ -560 +606 @@
 !==============================================================================================================================
 LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter
   CHARACTER(LEN=maxlen), ALLOCATABLE,           INTENT(OUT) :: keys(:)
@@ -570 +617 @@
   r  = TRIM(ADJUSTL(rawList))
   nr = LEN_TRIM(r); IF(nr == 0) THEN; keys = ['']; RETURN; END IF
-  CALL strParse_prv(nk)                                              !--- COUNT THE ELEMENTS
-  ALLOCATE(keys(nk))
-  IF(PRESENT(vals)) THEN
-    ALLOCATE(vals(nk)); CALL strParse_prv(nk, keys, vals)            !--- PARSE THE KEYS
-  ELSE
-    CALL strParse_prv(nk, keys)                                      !--- PARSE THE KEYS
-  END IF
-  IF(PRESENT(n)) n = nk
+  nk = countK()                                                      !--- COUNT THE ELEMENTS
+  CALL parseK(keys)                                                  !--- PARSE THE KEYS
+  IF(PRESENT(vals)) CALL parseV(vals)                                !--- PARSE <key>=<val> PAIRS
+  IF(PRESENT(n)) n = nk                                              !--- RETURN THE NUMBER OF KEYS
 
 CONTAINS
 
 !------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE strParse_prv(nkeys, keys, vals)
-!--- * Get the number of elements after parsing ("nkeys" only is present)
-!--- * Parse the <key>=<val> pairs and store result in "keys" and "vals" (already allocated)
-  IMPLICIT NONE
-  INTEGER,                         INTENT(OUT) :: nkeys
-  CHARACTER(LEN=maxlen), OPTIONAL, INTENT(OUT) :: keys(:)
-  CHARACTER(LEN=maxlen), OPTIONAL, INTENT(OUT) :: vals(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ib, ie
-  nkeys = 1; ib = 1
+INTEGER FUNCTION countK() RESULT(nkeys)
+!--- Get the number of elements after parsing.
+  IMPLICIT NONE
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: ib, ie, nl
+  nkeys = 1; ib = 1; nl = LEN(delimiter)
   DO
     ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
     IF(ie == ib-1) EXIT
-    IF(PRESENT(keys)) keys(nkeys) = r(ib:ie-1)                       !--- Get the ikth key
-    IF(PRESENT(vals)) CALL parseKeys(keys(nkeys), vals(nkeys))       !--- Parse the ikth <key>=<val> pair
+    ib = ie + nl
+    DO WHILE(ANY([0, 9, 32] == IACHAR(r(ib:ib))) .AND. ib < nr)      !--- Skip blanks (ascii): NULL (0), TAB (9), SPACE (32)
+      ib = ib + 1
+    END DO     !--- Skip spaces before next chain
+    nkeys = nkeys+1
+  END DO
+END FUNCTION countK
+
+!------------------------------------------------------------------------------------------------------------------------------
+SUBROUTINE parseK(keys)
+!--- Parse the string separated by "delimiter" from "rawList" into "keys(:)"
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: ib, ie, ik
+  ALLOCATE(keys(nk))
+  ib = 1
+  DO ik = 1, nk
+    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
+    IF(ie == ib-1) EXIT
+    keys(ik) = r(ib:ie-1)                                            !--- Get the ikth key
     ib = ie + LEN(delimiter)
     DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
-    nkeys = nkeys+1
-  END DO
-  IF(PRESENT(keys)) keys(nkeys) = r(ib:nr)                           !--- Get the last key
-  IF(PRESENT(vals)) CALL parseKeys(keys(nkeys), vals(nkeys))         !--- Parse the last <key>=<val> pair
-END SUBROUTINE strParse_prv
-
-!------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE parseKeys(key, val)
-  CHARACTER(LEN=*), INTENT(INOUT) :: key
-  CHARACTER(LEN=*), INTENT(OUT)   :: val
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ix
-  ix = INDEX(key, '='); IF(ix == 0) RETURN                           !--- First "=" index in "key"
-  val = ADJUSTL(key(ix+1:LEN_TRIM(key)))
-  key = ADJUSTL(key(1:ix-1))
-END SUBROUTINE parseKeys
+  END DO
+  keys(ik) = r(ib:nr)                                                !--- Get the last key
+END SUBROUTINE parseK
+
+!------------------------------------------------------------------------------------------------------------------------------
+SUBROUTINE parseV(vals)
+!--- Parse the <key>=<val> pairs in "keys(:)" into "keys" and "vals"
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vals(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: key
+  INTEGER :: ik, ix
+  ALLOCATE(vals(nk))
+  DO ik = 1, nk; key = keys(ik)
+    vals(ik) = ''
+    ix = INDEX(key, '='); IF(ix == 0) CYCLE                          !--- First "=" index in "key"
+    vals(ik) = ADJUSTL(key(ix+1:LEN_TRIM(key)))
+    keys(ik) = ADJUSTL(key(1:ix-1))
+  END DO
+END SUBROUTINE parseV
 
 END FUNCTION strParse
 !==============================================================================================================================
 LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter(:)
   CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: keys(:)  !--- Parsed keys vector
@@ -630 +693 @@
   LOGICAL :: ll
   ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
-  IF(test(fmsg("Couldn't parse list: non-numerical strings were found", ll=strCount_1m(rawList, delimiter, nk, ll)),lerr)) RETURN
+  lerr = strCount_1m(rawList, delimiter, nk, ll)
+  CALL msg("Couldn't parse list: non-numerical strings were found", ll=lerr); IF(lerr) RETURN
 
   !--- FEW ALLOCATIONS
@@ -643 +707 @@
   ib = 1
   DO ik = 1, nk-1
-    IF(test(fmsg('Non-numeric values found', ll=strIdx_prv(r, delimiter, ib, ie, jd, ll)),lerr)) RETURN
+    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
+    CALL msg('Non-numeric values found', ll=lerr); IF(lerr) RETURN
     keys(ik) = r(ib:ie-1)
     IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik))             !--- Parse a <key>=<val> pair
@@ -657 +722 @@
 !------------------------------------------------------------------------------------------------------------------------------
 SUBROUTINE parseKeys(key, val)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(INOUT) :: key
   CHARACTER(LEN=*), INTENT(OUT)   :: val
@@ -674 +740 @@
 !==============================================================================================================================
 SUBROUTINE strReplace_1(str, key, val, lsurr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(INOUT) :: str        !--- Main string
   CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
@@ -700 +767 @@
 !==============================================================================================================================
 SUBROUTINE strReplace_m(str, key, val, lsurr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),  INTENT(INOUT) :: str(:)     !--- Main strings vector
   CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
@@ -714 +782 @@
 !=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array ===================================
 !==============================================================================================================================
-FUNCTION horzcat_s1(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
-  CHARACTER(LEN=*),           TARGET, INTENT(IN) :: s0
+FUNCTION horzcat_s00(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),                   INTENT(IN) :: s0
   CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
   CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
   CHARACTER(LEN=maxlen), POINTER     :: s
-  LOGICAL :: lv(10)
-  INTEGER :: iv
-  lv = [   .TRUE.   , PRESENT(s1), PRESENT(s2), PRESENT(s3), PRESENT(s4) , &
-         PRESENT(s5), PRESENT(s6), PRESENT(s7), PRESENT(s8), PRESENT(s9) ]
-  ALLOCATE(out(COUNT(lv)))
-  DO iv=1, COUNT(lv)
-    SELECT CASE(iv)
-      CASE(1); s=> s0; CASE(2); s=> s1; CASE(3); s=> s2; CASE(4); s=> s3; CASE(5); s=> s4
-      CASE(6); s=> s5; CASE(7); s=> s6; CASE(8); s=> s7; CASE(9); s=> s8; CASE(10);s=> s9
+  INTEGER                            :: nrow, iv
+  LOGICAL                            :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
+  nrow = 1+COUNT(pre)
+  ALLOCATE(out(nrow))
+  out(1) = s0
+  DO iv = 2, nrow; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
+      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
     END SELECT
     out(iv) = s
   END DO
-END FUNCTION horzcat_s1
-!==============================================================================================================================
-FUNCTION horzcat_sm(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
-  CHARACTER(LEN=*),           TARGET, DIMENSION(:), INTENT(IN) :: s0
-  CHARACTER(LEN=*), OPTIONAL, TARGET, DIMENSION(:), INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
+END FUNCTION horzcat_s00
+!==============================================================================================================================
+FUNCTION horzcat_s10(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: s0(:), s1
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2, s3, s4, s5, s6, s7, s8, s9
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc = SIZE(s0)
+  tmp = horzcat_s00(s0(nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [s0(1:nc-1), tmp]
+END FUNCTION horzcat_s10
+!==============================================================================================================================
+FUNCTION horzcat_s11(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),                   INTENT(IN) :: s0(:)
+  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1(:), s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
   CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:)
-!------------------------------------------------------------------------------------------------------------------------------
   CHARACTER(LEN=maxlen), POINTER     :: s(:)
-  LOGICAL :: lv(10)
-  INTEGER :: nrow, ncol, iv, n
-  lv = [   .TRUE.   , PRESENT(s1), PRESENT(s2), PRESENT(s3), PRESENT(s4) , &
-         PRESENT(s5), PRESENT(s6), PRESENT(s7), PRESENT(s8), PRESENT(s9) ]
-  nrow = SIZE(s0); ncol=COUNT(lv)
+  INTEGER                            :: nrow, ncol, iv, n
+  LOGICAL                            :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
+  nrow = SIZE(s0)
+  ncol = 1+COUNT(pre)
   ALLOCATE(out(nrow, ncol))
-  DO iv=1, ncol
-    SELECT CASE(iv)
-      CASE(1); s=> s0; CASE(2); s=> s1; CASE(3); s=> s2; CASE(4); s=> s3; CASE(5); s=> s4
-      CASE(6); s=> s5; CASE(7); s=> s6; CASE(8); s=> s7; CASE(9); s=> s8; CASE(10);s=> s9
+  out(:,1) = s0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
+      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
     END SELECT
     n = SIZE(s, DIM=1)
-    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
     out(:,iv) = s(:)
   END DO
-END FUNCTION horzcat_sm
-!==============================================================================================================================
-FUNCTION horzcat_i1(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
-  INTEGER,           TARGET, INTENT(IN) :: i0
+END FUNCTION horzcat_s11
+!==============================================================================================================================
+FUNCTION horzcat_s21(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: s0(:,:), s1(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(s0, 2)
+  tmp = horzcat_s11(s0(:,nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(s0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_s21
+!==============================================================================================================================
+FUNCTION horzcat_i00(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,                   INTENT(IN) :: i0
   INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9
   INTEGER, ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
   INTEGER, POINTER     :: i
-  LOGICAL :: lv(10)
-  INTEGER :: iv
-  lv = [   .TRUE.   , PRESENT(i1), PRESENT(i2), PRESENT(i3), PRESENT(i4) , &
-         PRESENT(i5), PRESENT(i6), PRESENT(i7), PRESENT(i8), PRESENT(i9) ]
-  ALLOCATE(out(COUNT(lv)))
-  DO iv=1, COUNT(lv)
-    SELECT CASE(iv)
-      CASE(1); i=> i0; CASE(2); i=> i1; CASE(3); i=> i2; CASE(4); i=> i3; CASE(5); i=> i4
-      CASE(6); i=> i5; CASE(7); i=> i6; CASE(8); i=> i7; CASE(9); i=> i8; CASE(10);i=> i9
+  INTEGER              :: ncol, iv
+  LOGICAL              :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
+  ncol = SIZE(pre)
+  ALLOCATE(out(ncol))
+  out(1) = i0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
+      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
     END SELECT
     out(iv) = i
   END DO
-END FUNCTION horzcat_i1
-!==============================================================================================================================
-FUNCTION horzcat_im(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
-  INTEGER,           TARGET, DIMENSION(:), INTENT(IN) :: i0
-  INTEGER, OPTIONAL, TARGET, DIMENSION(:), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9
+END FUNCTION horzcat_i00
+!==============================================================================================================================
+FUNCTION horzcat_i10(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN) :: i0(:), i1
+  INTEGER, OPTIONAL, INTENT(IN) :: i2, i3, i4, i5, i6, i7, i8, i9
+  INTEGER, ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc = SIZE(i0)
+  tmp = horzcat_i00(i0(nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [i0(1:nc-1), tmp]
+END FUNCTION horzcat_i10
+!==============================================================================================================================
+FUNCTION horzcat_i11(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,                   INTENT(IN) :: i0(:)
+  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1(:), i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
   INTEGER, ALLOCATABLE :: out(:,:)
-!------------------------------------------------------------------------------------------------------------------------------
   INTEGER, POINTER     :: i(:)
-  LOGICAL :: lv(10)
-  INTEGER :: nrow, ncol, iv, n
-  lv = [   .TRUE.   , PRESENT(i1), PRESENT(i2), PRESENT(i3), PRESENT(i4) , &
-         PRESENT(i5), PRESENT(i6), PRESENT(i7), PRESENT(i8), PRESENT(i9) ]
-  nrow = SIZE(i0); ncol=COUNT(lv)
+  INTEGER              :: nrow, ncol, iv, n
+  LOGICAL              :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
+  nrow = SIZE(i0)
+  ncol = 1+COUNT(pre)
   ALLOCATE(out(nrow, ncol))
-  DO iv=1, ncol
-    SELECT CASE(iv)
-      CASE(1); i=> i0; CASE(2); i=> i1; CASE(3); i=> i2; CASE(4); i=> i3; CASE(5); i=> i4
-      CASE(6); i=> i5; CASE(7); i=> i6; CASE(8); i=> i7; CASE(9); i=> i8; CASE(10);i=> i9
+  out(:,1) = i0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
+      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
     END SELECT
     n = SIZE(i, DIM=1)
-    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
     out(:,iv) = i(:)
   END DO
-END FUNCTION horzcat_im
-!==============================================================================================================================
-FUNCTION horzcat_r1(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
-  REAL,           TARGET, INTENT(IN) :: r0
+END FUNCTION horzcat_i11
+!==============================================================================================================================
+FUNCTION horzcat_i21(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN) :: i0(:,:), i1(:)
+  INTEGER, OPTIONAL, INTENT(IN) :: i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
+  INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(i0, 2)
+  tmp = horzcat_i11(i0(:,nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(i0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(i0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_i21
+!==============================================================================================================================
+FUNCTION horzcat_r00(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,                   INTENT(IN) :: r0
   REAL, OPTIONAL, TARGET, INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9
   REAL, ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
   REAL, POINTER     :: r
-  LOGICAL :: lv(10)
-  INTEGER :: iv
-  lv = [   .TRUE.   , PRESENT(r1), PRESENT(r2), PRESENT(r3), PRESENT(r4) , &
-         PRESENT(r5), PRESENT(r6), PRESENT(r7), PRESENT(r8), PRESENT(r9) ]
-  ALLOCATE(out(COUNT(lv)))
-  DO iv=1, COUNT(lv)
-    SELECT CASE(iv)
-      CASE(1); r=> r0; CASE(2); r=> r1; CASE(3); r=> r2; CASE(4); r=> r3; CASE(5); r=> r4
-      CASE(6); r=> r5; CASE(7); r=> r6; CASE(8); r=> r7; CASE(9); r=> r8; CASE(10);r=> r9
+  INTEGER           :: ncol, iv
+  LOGICAL           :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(ncol))
+  out(1) = r0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
+      CASE(6); r=> r6; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
     END SELECT
     out(iv) = r
   END DO
-END FUNCTION horzcat_r1
-!==============================================================================================================================
-FUNCTION horzcat_rm(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
-  REAL,           TARGET, DIMENSION(:), INTENT(IN) :: r0
-  REAL, OPTIONAL, TARGET, DIMENSION(:), INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9
+END FUNCTION horzcat_r00
+!==============================================================================================================================
+FUNCTION horzcat_r10(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,           INTENT(IN) :: r0(:), r1
+  REAL, OPTIONAL, INTENT(IN) :: r2, r3, r4, r5, r6, r7, r8, r9
+  REAL, ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc  = SIZE(r0)
+  tmp = horzcat_r00(r0(nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [r0(1:nc-1), tmp]
+END FUNCTION horzcat_r10
+!==============================================================================================================================
+FUNCTION horzcat_r11(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,                   INTENT(IN) :: r0(:)
+  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1(:), r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
   REAL, ALLOCATABLE :: out(:,:)
-!------------------------------------------------------------------------------------------------------------------------------
   REAL, POINTER     :: r(:)
-  LOGICAL :: lv(10)
-  INTEGER :: nrow, ncol, iv, n
-  lv = [   .TRUE.   , PRESENT(r1), PRESENT(r2), PRESENT(r3), PRESENT(r4) , &
-         PRESENT(r5), PRESENT(r6), PRESENT(r7), PRESENT(r8), PRESENT(r9) ]
-  nrow = SIZE(r0); ncol=COUNT(lv)
+  INTEGER           :: nrow, ncol, iv, n
+  LOGICAL           :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
+  nrow = SIZE(r0)
+  ncol = 1+COUNT(pre)
   ALLOCATE(out(nrow, ncol))
-  DO iv=1, ncol
-    SELECT CASE(iv)
-      CASE(1); r=> r0; CASE(2); r=> r1; CASE(3); r=> r2; CASE(4); r=> r3; CASE(5); r=> r4
-      CASE(6); r=> r5; CASE(7); r=> r6; CASE(8); r=> r7; CASE(9); r=> r8; CASE(10);r=> r9
+  out(:,1) = r0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
+      CASE(6); r=> r5; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
     END SELECT
     n = SIZE(r, DIM=1)
-    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
     out(:,iv) = r(:)
   END DO
-END FUNCTION horzcat_rm
-!==============================================================================================================================
-FUNCTION horzcat_d1(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
-  DOUBLE PRECISION,           TARGET, INTENT(IN) :: d0
+END FUNCTION horzcat_r11
+!==============================================================================================================================
+FUNCTION horzcat_r21(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,           INTENT(IN) :: r0(:,:), r1(:)
+  REAL, OPTIONAL, INTENT(IN) :: r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
+  REAL, ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(r0, 2)
+  tmp = horzcat_r11(r0(:,nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(r0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(r0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_r21
+!==============================================================================================================================
+FUNCTION horzcat_d00(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,                   INTENT(IN) :: d0
   DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9
   DOUBLE PRECISION, ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
   DOUBLE PRECISION, POINTER     :: d
-  LOGICAL :: lv(10)
-  INTEGER :: iv
-  lv = [   .TRUE.   , PRESENT(d1), PRESENT(d2), PRESENT(d3), PRESENT(d4) , &
-         PRESENT(d5), PRESENT(d6), PRESENT(d7), PRESENT(d8), PRESENT(d9) ]
-  ALLOCATE(out(COUNT(lv)))
-  DO iv=1, COUNT(lv)
-    SELECT CASE(iv)
-      CASE(1); d=> d0; CASE(2); d=> d1; CASE(3); d=> d2; CASE(4); d=> d3; CASE(5); d=> d4
-      CASE(6); d=> d5; CASE(7); d=> d6; CASE(8); d=> d7; CASE(9); d=> d8; CASE(10);d=> d9
+  INTEGER                       :: ncol, iv
+  LOGICAL                       :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(ncol))
+  out(1) = d0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
+      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
     END SELECT
     out(iv) = d
   END DO
-END FUNCTION horzcat_d1
-!==============================================================================================================================
-FUNCTION horzcat_dm(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
-  DOUBLE PRECISION,           TARGET, DIMENSION(:), INTENT(IN) :: d0
-  DOUBLE PRECISION, OPTIONAL, TARGET, DIMENSION(:), INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9
+END FUNCTION horzcat_d00
+!==============================================================================================================================
+FUNCTION horzcat_d10(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,           INTENT(IN) :: d0(:), d1
+  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2, d3, d4, d5, d6, d7, d8, d9
+  DOUBLE PRECISION, ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc = SIZE(d0)
+  tmp = horzcat_d00(d0(nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [d0(1:nc-1), tmp]
+END FUNCTION horzcat_d10
+!==============================================================================================================================
+FUNCTION horzcat_d11(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,                   INTENT(IN) :: d0(:)
+  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1(:), d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
   DOUBLE PRECISION, ALLOCATABLE :: out(:,:)
-!------------------------------------------------------------------------------------------------------------------------------
   DOUBLE PRECISION, POINTER     :: d(:)
-  LOGICAL :: lv(10)
-  INTEGER :: nrow, ncol, iv, n
-  lv = [   .TRUE.   , PRESENT(d1), PRESENT(d2), PRESENT(d3), PRESENT(d4) , &
-         PRESENT(d5), PRESENT(d6), PRESENT(d7), PRESENT(d8), PRESENT(d9) ]
-  nrow = SIZE(d0); ncol=COUNT(lv)
+  INTEGER                       :: nrow, ncol, iv, n
+  LOGICAL                       :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  nrow = SIZE(d0)
+  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
+  ncol = 1+COUNT(pre)
   ALLOCATE(out(nrow, ncol))
-  DO iv=1, ncol
-    SELECT CASE(iv)
-      CASE(1); d=> d0; CASE(2); d=> d1; CASE(3); d=> d2; CASE(4); d=> d3; CASE(5); d=> d4
-      CASE(6); d=> d5; CASE(7); d=> d6; CASE(8); d=> d7; CASE(9); d=> d8; CASE(10);d=> d9
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
+      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
     END SELECT
     n = SIZE(d, DIM=1)
-    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
     out(:,iv) = d(:)
   END DO
-END FUNCTION horzcat_dm
+END FUNCTION horzcat_d11
+!==============================================================================================================================
+FUNCTION horzcat_d21(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,           INTENT(IN) :: d0(:,:), d1(:)
+  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
+  DOUBLE PRECISION, ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(d0, 2)
+  tmp = horzcat_d11(d0(:,nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(d0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(d0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_d21
 !==============================================================================================================================
 
@@ -896 +1075 @@
 !==============================================================================================================================
 LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
   CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
@@ -1004 +1184 @@
 !==============================================================================================================================
 LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr)
+  IMPLICIT NONE
   INTEGER,                    INTENT(IN)  :: unt           !--- Output unit
   CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
@@ -1086 +1267 @@
 !==============================================================================================================================
 LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr)
+  IMPLICIT NONE
 ! Display outliers list in tables
 ! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
@@ -1115 +1297 @@
 
   rk = SIZE(n); nv = SIZE(vnm)
-  IF(test(fmsg('SIZE(nam) /= 1 and /= last "n" element', sub, nv /= 1 .AND. nv /= n(rk), unt),lerr)) RETURN
-  IF(test(fmsg('ll" and "a" sizes mismatch',             sub, SIZE(a) /= SIZE(ll),       unt),lerr)) RETURN
-  IF(test(fmsg('profile "n" does not match "a" and "ll', sub, SIZE(a) /= PRODUCT(n),     unt),lerr)) RETURN
+  lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN
+  lerr = SIZE(a) /=   SIZE(ll); CALL msg('ll" and "a" sizes mismatch',             sub, lerr); IF(lerr) RETURN
+  lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN
   CALL msg(mes, sub, unit=unt)
 
@@ -1164 +1346 @@
 !==============================================================================================================================
 LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr)
+  IMPLICIT NONE
 ! Display outliers list in tables
 ! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2.
@@ -1221 +1404 @@
 !==============================================================================================================================
 LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),      INTENT(IN)  :: str
   CHARACTER(LEN=maxlen), INTENT(OUT) :: val
@@ -1254 +1438 @@
   DO WHILE(nl > 1)
     i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO
-    IF(test(reduceExpr_basic(vl(i+1), v), lerr)) RETURN
+    lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN
     v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2))
     vv = v//REPEAT(' ',768)
@@ -1270 +1454 @@
 !==============================================================================================================================
 LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
+  IMPLICIT NONE
   CHARACTER(LEN=*),      INTENT(IN)  :: str
   CHARACTER(LEN=*),      INTENT(OUT) :: val
@@ -1284 +1469 @@
   op = ['^','/','*','+','-']                                                   !--- List of recognized operations
   s = str
-  IF(test(strParse_m(s, op, ky, lSc=.TRUE., id = id), lerr)) RETURN            !--- Parse the values
+  lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id)                            !--- Parse the values
+  IF(lerr) RETURN                                                              !--- Problem with the parsing
   vl = str2dble(ky)                                                            !--- Conversion to doubles
   lerr = ANY(vl >= HUGE(1.d0))
-  IF(fmsg('Some values are non-numeric in: '//TRIM(s), ll=lerr)) RETURN        !--- Non-numerical values found
+  CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr)
+  IF(lerr) RETURN                                                              !--- Non-numerical values found
   DO io = 1, SIZE(op)                                                          !--- Loop on known operators (order matters !)
     DO i = SIZE(id), 1, -1                                                     !--- Loop on found operators
@@ -1293 +1480 @@
       IF(id(i) /= io) CYCLE                                                    !--- Current found operator is not op(io)
       vm = vl(i); vp = vl(i+1)                                                 !--- Couple of values used for current operation
-      SELECT CASE(op(io))                                                          !--- Perform operation on the two values
+      SELECT CASE(op(io))                                                      !--- Perform operation on the two values
         CASE('^'); v = vm**vp
         CASE('/'); v = vm/vp
@@ -1311 +1498 @@
 !==============================================================================================================================
 FUNCTION reduceExpr_m(str, val) RESULT(lerr)
+  IMPLICIT NONE
   LOGICAL,               ALLOCATABLE              :: lerr(:)
   CHARACTER(LEN=*),                   INTENT(IN)  :: str(:)
@@ -1326 +1514 @@
 !==============================================================================================================================
 ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   REAL    :: x
@@ -1341 +1530 @@
 !=== Convert a string into a logical/integer integer or an integer/real into a string =========================================
 !==============================================================================================================================
-ELEMENTAL LOGICAL FUNCTION str2bool(str) RESULT(out)
+ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out)  !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   INTEGER :: ierr
-  READ(str,*,IOSTAT=ierr) out
-  IF(ierr==0) RETURN
-  out = ANY(['t     ','true  ','.true.','y     ','yes   ']==strLower(str))
+  LOGICAL :: lout
+  READ(str,*,IOSTAT=ierr) lout
+  out = -HUGE(1)
+  IF(ierr /= 0) THEN
+    IF(ANY(['.false.', 'false  ', 'no     ', 'f      ', 'n      '] == strLower(str))) out = 0
+    IF(ANY(['.true. ', 'true   ', 'yes    ', 't      ', 'y      '] == strLower(str))) out = 1
+  ELSE
+    out = 0; IF(lout) out = 1
+  END IF
 END FUNCTION str2bool
 !==============================================================================================================================
 ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   INTEGER :: ierr
@@ -1357 +1554 @@
 !==============================================================================================================================
 ELEMENTAL REAL FUNCTION str2real(str) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   INTEGER :: ierr
@@ -1364 +1562 @@
 !==============================================================================================================================
 ELEMENTAL DOUBLE PRECISION FUNCTION str2dble(str) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: str
   INTEGER :: ierr
@@ -1371 +1570 @@
 !==============================================================================================================================
 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out)
+  IMPLICIT NONE
   LOGICAL, INTENT(IN) :: b
   WRITE(out,*)b
@@ -1377 +1577 @@
 !==============================================================================================================================
 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out)
+  IMPLICIT NONE
   INTEGER,           INTENT(IN) :: i
   INTEGER, OPTIONAL, INTENT(IN) :: nDigits
@@ -1387 +1588 @@
 !==============================================================================================================================
 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out)
+  IMPLICIT NONE
   REAL,                       INTENT(IN) :: r
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
@@ -1396 +1598 @@
 !==============================================================================================================================
 ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out)
+  IMPLICIT NONE
   DOUBLE PRECISION,           INTENT(IN) :: d
   CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
@@ -1405 +1608 @@
 !==============================================================================================================================
 ELEMENTAL SUBROUTINE cleanZeros(s)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(INOUT) :: s
   INTEGER :: ls, ix, i
@@ -1422 +1626 @@
 !==============================================================================================================================
 FUNCTION addQuotes_1(s) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN)  :: s
   CHARACTER(LEN=:), ALLOCATABLE :: out
@@ -1428 +1633 @@
 !==============================================================================================================================
 FUNCTION addQuotes_m(s) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN)  :: s(:)
   CHARACTER(LEN=:), ALLOCATABLE :: out(:)
@@ -1440 +1646 @@
 !==============================================================================================================================
 ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(IN) :: s
   CHARACTER(LEN=1) :: b, e
@@ -1454 +1661 @@
 !==============================================================================================================================
 LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out)
+  IMPLICIT NONE
 ! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector).
 ! Note:    Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE).
@@ -1476 +1684 @@
 !==============================================================================================================================
 SUBROUTINE removeComment(str)
+  IMPLICIT NONE
   CHARACTER(LEN=*), INTENT(INOUT) :: str
   INTEGER :: ix

LMDZ6/branches/cirrus/libf/phylmd/Dust/phys_output_write_spl_mod.F90

@@ -325 +325 @@
          sissnow, runoff, albsol3_lic, evap_pot, &
          t2m, fluxt, fluxlat, fsollw, fsolsw, &
-         wfbils, wfbilo, cdragm, cdragh, cldl, cldm, &
+         wfbils, cdragm, cdragh, cldl, cldm, &
          cldh, cldt, JrNt, &
          ! cldljn, cldmjn, cldhjn, cldtjn &
@@ -353 +353 @@
          toplwad_aero, toplwad0_aero, sollwad_aero, &
          sollwad0_aero, toplwai_aero, sollwai_aero, &
-         scdnc, cldncl, reffclws, reffclwc, cldnvi, &
-         lcc, lcc3d, lcc3dcon, lcc3dstra, reffclwtop, &
+         !scdnc, cldncl, reffclws, reffclwc, cldnvi, &
+         !lcc, lcc3d, lcc3dcon, lcc3dstra, reffclwtop, &
          ec550aer, flwc, fiwc, t_seri, theta, q_seri, &
 !jyg<
@@ -377 +377 @@
     USE phys_output_var_mod, ONLY: vars_defined, snow_o, zfra_o, bils_diss, &
          bils_ec,bils_ech, bils_tke, bils_kinetic, bils_latent, bils_enthalp, &
-         itau_con, nfiles, clef_files, nid_files, zvstr_gwd_rando
+         itau_con, nfiles, clef_files, nid_files, zvstr_gwd_rando, &
+         scdnc, cldncl, reffclws, reffclwc, cldnvi, &
+         lcc, lcc3d, lcc3dcon, lcc3dstra, reffclwtop
     USE ocean_slab_mod, ONLY: tslab, slab_bilg, tice, seaice
     USE pbl_surface_mod, ONLY: snow
@@ -721 +723 @@
           IF (vars_defined)         zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
           CALL histwrite_phy(o_wbils_srf(nsrf), zx_tmp_fi2d)
-          IF (vars_defined)         zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
-          CALL histwrite_phy(o_wbilo_srf(nsrf), zx_tmp_fi2d)
 
           IF (iflag_pbl > 1) THEN

LMDZ6/branches/cirrus/libf/phylmd/StratAer/aer_sedimnt.F90

@@ -17 +17 @@
 !-----------------------------------------------------------------------
 
-  USE phys_local_var_mod, ONLY: mdw, budg_sed_part, DENSO4, f_r_wet, vsed_aer
+  USE phys_local_var_mod, ONLY: mdw, budg_sed_part, DENSO4, DENSO4B, f_r_wet, f_r_wetB, vsed_aer
+  USE strataer_local_var_mod, ONLY: flag_new_strat_compo
   USE dimphy, ONLY : klon,klev
   USE infotrac_phy
@@ -89 +90 @@
 
       ! stokes-velocity with cunnigham slip- flow correction
-      ZVAER(JL,JK,nb) = 2./9.*(DENSO4(JL,JK)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wet(JL,JK)*mdw(nb)/2.)**2.* &
-         (1.+ 2.*zlair(JL,JK)/(f_r_wet(JL,JK)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wet(JL,JK)*mdw(nb)/zlair(JL,JK))))
-
+      IF(flag_new_strat_compo) THEN
+         ! stokes-velocity with cunnigham slip- flow correction
+         ZVAER(JL,JK,nb) = 2./9.*(DENSO4B(JL,JK,nb)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wetB(JL,JK,nb)*mdw(nb)/2.)**2.* &
+              (1.+ 2.*zlair(JL,JK)/(f_r_wetB(JL,JK,nb)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wetB(JL,JK,nb)*mdw(nb)/zlair(JL,JK))))
+      ELSE
+         ZVAER(JL,JK,nb) = 2./9.*(DENSO4(JL,JK)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wet(JL,JK)*mdw(nb)/2.)**2.* &
+              (1.+ 2.*zlair(JL,JK)/(f_r_wet(JL,JK)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wet(JL,JK)*mdw(nb)/zlair(JL,JK))))
+      ENDIF
+      
       ZSEDFLX(JL,nb)=ZVAER(JL,JK,nb)*ZRHO
       ZSOLAERB(nb)=ZSOLAERB(nb)+ZDTGDP*ZSEDFLX(JL,nb)

LMDZ6/branches/cirrus/libf/phylmd/StratAer/aerophys.F90

@@ -5 +5 @@
   IMPLICIT NONE
 !
-  REAL,PARAMETER                         :: ropx=1500.0              ! default aerosol particle mass density [kg/m3]
-  REAL,PARAMETER                         :: dens_aer_dry=1848.682308 ! dry aerosol particle mass density at T_0=293K[kg/m3]
-  REAL,PARAMETER                         :: dens_aer_ref=1483.905336 ! aerosol particle mass density with 75% H2SO4 at T_0=293K[kg/m3]
-  REAL,PARAMETER                         :: mdwmin=0.002e-6          ! dry diameter of smallest aerosol particles [m]
-  REAL,PARAMETER                         :: V_rat=2.0                ! volume ratio of neighboring size bins
-  REAL,PARAMETER                         :: mfrac_H2SO4=0.75         ! default mass fraction of H2SO4 in the aerosol
-  REAL, PARAMETER                        :: mAIRmol=28.949*1.66E-27  ! Average mass of an air molecule [kg]
-  REAL, PARAMETER                        :: mH2Omol=18.016*1.66E-27  ! Mass of an H2O molecule [kg]
-  REAL, PARAMETER                        :: mH2SO4mol=98.082*1.66E-27! Mass of an H2SO4 molecule [kg]
-  REAL, PARAMETER                        :: mSO2mol=64.06*1.66E-27   ! Mass of an SO2 molecule [kg]
-  REAL, PARAMETER                        :: mSatom=32.06*1.66E-27    ! Mass of a S atom [kg]
-  REAL, PARAMETER                        :: mOCSmol=60.07*1.66E-27   ! Mass of an OCS molecule [kg]
-  REAL, PARAMETER                        :: mClatom=35.45*1.66E-27   ! Mass of an Cl atom [kg]
-  REAL, PARAMETER                        :: mHClmol=36.46*1.66E-27   ! Mass of an HCl molecule [kg]
-  REAL, PARAMETER                        :: mBratom=79.90*1.66E-27   ! Mass of an Br atom [kg]
-  REAL, PARAMETER                        :: mHBrmol=80.92*1.66E-27   ! Mass of an HBr molecule [kg]
-  REAL, PARAMETER                        :: mNOmol=30.01*1.66E-27    ! Mass of an NO molecule [kg]
-  REAL, PARAMETER                        :: mNO2mol=46.01*1.66E-27   ! Mass of an NO2 molecule [kg]
-  REAL, PARAMETER                        :: mNatome=14.0067*1.66E-27 ! Mass of an N atome [kg] 
+  REAL,PARAMETER    :: ropx=1500.0              ! default aerosol particle mass density [kg/m3]
+  REAL,PARAMETER    :: dens_aer_dry=1848.682308 ! dry aerosol particle mass density at T_0=293K[kg/m3]
+  REAL,PARAMETER    :: dens_aer_ref=1483.905336 ! aerosol particle mass density with 75% H2SO4 at T_0=293K[kg/m3]
+  REAL,PARAMETER    :: mdwmin=0.002e-6          ! dry diameter of smallest aerosol particles [m]
+  REAL,PARAMETER    :: V_rat=2.0                ! volume ratio of neighboring size bins
+  REAL,PARAMETER    :: mfrac_H2SO4=0.75         ! default mass fraction of H2SO4 in the aerosol
+  REAL, PARAMETER   :: mAIRmol=28.949*1.66E-27  ! Average mass of an air molecule [kg]
+  REAL, PARAMETER   :: mH2Omol=18.016*1.66E-27  ! Mass of an H2O molecule [kg]
+  REAL, PARAMETER   :: mH2SO4mol=98.082*1.66E-27! Mass of an H2SO4 molecule [kg]
+  REAL, PARAMETER   :: mSO2mol=64.06*1.66E-27   ! Mass of an SO2 molecule [kg]
+  REAL, PARAMETER   :: mSatom=32.06*1.66E-27    ! Mass of a S atom [kg]
+  REAL, PARAMETER   :: mOCSmol=60.07*1.66E-27   ! Mass of an OCS molecule [kg]
+  REAL, PARAMETER   :: mClatom=35.45*1.66E-27   ! Mass of an Cl atom [kg]
+  REAL, PARAMETER   :: mHClmol=36.46*1.66E-27   ! Mass of an HCl molecule [kg]
+  REAL, PARAMETER   :: mBratom=79.90*1.66E-27   ! Mass of an Br atom [kg]
+  REAL, PARAMETER   :: mHBrmol=80.92*1.66E-27   ! Mass of an HBr molecule [kg]
+  REAL, PARAMETER   :: mNOmol=30.01*1.66E-27    ! Mass of an NO molecule [kg]
+  REAL, PARAMETER   :: mNO2mol=46.01*1.66E-27   ! Mass of an NO2 molecule [kg]
+  REAL, PARAMETER   :: mNatome=14.0067*1.66E-27 ! Mass of an N atome [kg]
+  REAL, PARAMETER   :: rgas=8.3145 ! molar gas cste (J⋅K−1⋅mol−1=m3⋅Pa⋅K−1⋅mol−1=kg⋅m2⋅s−2⋅K−1⋅mol−1)
+  ! 
+  REAL, PARAMETER   :: MH2O  =1000.*mH2Omol     ! Mass of 1 molec [g] (18.016*1.66E-24)
+  REAL, PARAMETER   :: MH2SO4=1000.*mH2SO4mol   ! Mass of 1 molec [g] (98.082*1.66E-24)
+  REAL, PARAMETER   :: BOLZ  =1.381E-16         ! Boltzmann constant [dyn.cm/K]
 !
 END MODULE aerophys

LMDZ6/branches/cirrus/libf/phylmd/StratAer/coagulate.F90

@@ -26 +26 @@
   USE aerophys
   USE infotrac_phy
-  USE phys_local_var_mod, ONLY: DENSO4, f_r_wet
-
+  USE phys_local_var_mod, ONLY: DENSO4, DENSO4B, f_r_wet, f_r_wetB
+  USE strataer_local_var_mod, ONLY: flag_new_strat_compo
+  
   IMPLICIT NONE
 
@@ -43 +44 @@
   ! local variables in coagulation routine
   INTEGER                                       :: i,j,k,nb,ilon,ilev
-  REAL, DIMENSION(nbtr_bin)                     :: radius ! aerosol particle radius in each bin [m]
+  REAL, DIMENSION(nbtr_bin)                     :: radiusdry ! dry aerosol particle radius in each bin [m]
+  REAL, DIMENSION(nbtr_bin)                     :: radiuswet ! wet aerosol particle radius in each bin [m]
   REAL, DIMENSION(klon,klev,nbtr_bin)           :: tr_t ! Concentration Traceur at time t [U/KgA]
   REAL, DIMENSION(klon,klev,nbtr_bin)           :: tr_tp1 ! Concentration Traceur at time t+1 [U/KgA]
   REAL, DIMENSION(nbtr_bin,nbtr_bin,nbtr_bin)   :: ff   ! Volume fraction of intermediate particles
-  REAL, DIMENSION(nbtr_bin)                     :: V    ! Volume of bins
+  REAL, DIMENSION(nbtr_bin)                     :: Vdry ! Volume dry of bins
+  REAL, DIMENSION(nbtr_bin)                     :: Vwet ! Volume wet of bins
   REAL, DIMENSION(nbtr_bin,nbtr_bin)            :: Vij  ! Volume sum of i and j
   REAL                                          :: eta  ! Dynamic viscosity of air
@@ -82 +85 @@
   include "YOMCST.h"
 
-  DO i=1, nbtr_bin
-   radius(i)=mdw(i)/2.
-   V(i)= radius(i)**3.  !neglecting factor 4*RPI/3
-  ENDDO
-
-  DO j=1, nbtr_bin
-  DO i=1, nbtr_bin
-   Vij(i,j)= V(i)+V(j)
-  ENDDO
-  ENDDO
-
+! ff(i,j,k): Volume fraction of Vi,j that is partitioned to each model bin k
+! just need to be calculated in model initialization because mdw(:) size is fixed
+! no need to recalculate radius, Vdry, Vij, and ff every timestep because it is for  
+! dry aerosols
+  DO i=1, nbtr_bin
+     radiusdry(i)=mdw(i)/2.
+     Vdry(i)=radiusdry(i)**3.  !neglecting factor 4*RPI/3
+     Vwet(i)=0.0
+  ENDDO
+
+  DO j=1, nbtr_bin
+     DO i=1, nbtr_bin
+        Vij(i,j)= Vdry(i)+Vdry(j)
+     ENDDO
+  ENDDO
+  
 !--pre-compute the f(i,j,k) from Jacobson equation 13
   ff=0.0 
@@ -100 +108 @@
     IF (k.EQ.1) THEN
       ff(i,j,k)= 0.0
-    ELSEIF (k.GT.1.AND.V(k-1).LT.Vij(i,j).AND.Vij(i,j).LT.V(k)) THEN
+    ELSEIF (k.GT.1.AND.Vdry(k-1).LT.Vij(i,j).AND.Vij(i,j).LT.Vdry(k)) THEN
       ff(i,j,k)= 1.-ff(i,j,k-1)
     ELSEIF (k.EQ.nbtr_bin) THEN
-      IF (Vij(i,j).GE.v(k)) THEN
+      IF (Vij(i,j).GE.Vdry(k)) THEN
         ff(i,j,k)= 1.
       ELSE
         ff(i,j,k)= 0.0
       ENDIF
-    ELSEIF (k.LE.(nbtr_bin-1).AND.V(k).LE.Vij(i,j).AND.Vij(i,j).LT.V(k+1)) THEN
-      ff(i,j,k)= V(k)/Vij(i,j)*(V(k+1)-Vij(i,j))/(V(k+1)-V(k))
+    ELSEIF (k.LE.(nbtr_bin-1).AND.Vdry(k).LE.Vij(i,j).AND.Vij(i,j).LT.Vdry(k+1)) THEN
+      ff(i,j,k)= Vdry(k)/Vij(i,j)*(Vdry(k+1)-Vij(i,j))/(Vdry(k+1)-Vdry(k))
     ENDIF
   ENDDO
   ENDDO
   ENDDO
-
+! End of just need to be calculated at initialization because mdw(:) size is fixed
+  
   DO ilon=1, klon
   DO ilev=1, klev 
@@ -120 +129 @@
   IF (is_strato(ilon,ilev)) THEN
   !compute actual wet particle radius & volume for every grid box
-  DO i=1, nbtr_bin
-   radius(i)=f_r_wet(ilon,ilev)*mdw(i)/2.
-   V(i)= radius(i)**3.  !neglecting factor 4*RPI/3
-  ENDDO
-
+  IF(flag_new_strat_compo) THEN
+     DO i=1, nbtr_bin
+        radiuswet(i)=f_r_wetB(ilon,ilev,i)*mdw(i)/2.
+        Vwet(i)= radiuswet(i)**3.  !neglecting factor 4*RPI/3
+!!      Vwet(i)= Vdry(i)*(f_r_wetB(ilon,ilev,i)**3)
+     ENDDO
+  ELSE
+     DO i=1, nbtr_bin
+        radiuswet(i)=f_r_wet(ilon,ilev)*mdw(i)/2.
+        Vwet(i)= radiuswet(i)**3.  !neglecting factor 4*RPI/3
+!!      Vwet(i)= Vdry(i)*(f_r_wet(ilon,ilev)**3)
+     ENDDO
+  ENDIF
+  
 !--Calculations for the coagulation kernel---------------------------------------------------------
 
@@ -150 +168 @@
   Di=0.0
   DO i=1, nbtr_bin
-   Kn(i)=mnfrpth/radius(i)
-   Di(i)=RKBOL*t_seri(ilon,ilev)/(6.*RPI*radius(i)*eta)*(1.+Kn(i)*(1.249+0.42*exp(-0.87/Kn(i))))
+      Kn(i)=mnfrpth/radiuswet(i)
+      Di(i)=RKBOL*t_seri(ilon,ilev)/(6.*RPI*radiuswet(i)*eta)*(1.+Kn(i)*(1.249+0.42*exp(-0.87/Kn(i))))
   ENDDO
 
 !--pre-compute the thermal velocity of a particle thvelpar(i) from equation 20
   thvelpar=0.0
-  DO i=1, nbtr_bin
-   m_par(i)=4./3.*RPI*radius(i)**3.*DENSO4(ilon,ilev)*1000.
-   thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
-  ENDDO
+  IF(flag_new_strat_compo) THEN
+     DO i=1, nbtr_bin
+        m_par(i)=4./3.*RPI*radiuswet(i)**3.*DENSO4B(ilon,ilev,i)*1000.
+        thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
+     ENDDO
+  ELSE
+     DO i=1, nbtr_bin
+        m_par(i)=4./3.*RPI*radiuswet(i)**3.*DENSO4(ilon,ilev)*1000.
+        thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
+     ENDDO
+  ENDIF
 
 !--pre-compute the particle mean free path mfppar(i) from equation 22
@@ -171 +196 @@
   delta=0.0
   DO i=1, nbtr_bin
-   delta(i)=((2.*radius(i)+mfppar(i))**3.-(4.*radius(i)**2.+mfppar(i)**2.)**1.5)/ &
-           & (6.*radius(i)*mfppar(i))-2.*radius(i)
-  ENDDO
-
+      delta(i)=((2.*radiuswet(i)+mfppar(i))**3.-(4.*radiuswet(i)**2.+mfppar(i)**2.)**1.5)/ &
+           & (6.*radiuswet(i)*mfppar(i))-2.*radiuswet(i)
+  ENDDO
+
+!   beta(i,j): coagulation kernel (rate coefficient) of 2 colliding particles i,j 
 !--pre-compute the beta(i,j) from equation 17 in Jacobson
   num=0.0
@@ -180 +206 @@
   DO i=1, nbtr_bin
 !
-   num=4.*RPI*(radius(i)+radius(j))*(Di(i)+Di(j))
-   denom=(radius(i)+radius(j))/(radius(i)+radius(j)+sqrt(delta(i)**2.+delta(j)**2.))+ &
-        & 4.*(Di(i)+Di(j))/(sqrt(thvelpar(i)**2.+thvelpar(j)**2.)*(radius(i)+radius(j)))
-   beta(i,j)=num/denom
+     num=4.*RPI*(radiuswet(i)+radiuswet(j))*(Di(i)+Di(j))
+     denom=(radiuswet(i)+radiuswet(j))/(radiuswet(i)+radiuswet(j)+sqrt(delta(i)**2.+delta(j)**2.))+ &
+          & 4.*(Di(i)+Di(j))/(sqrt(thvelpar(i)**2.+thvelpar(j)**2.)*(radiuswet(i)+radiuswet(j)))
+     beta(i,j)=num/denom
 !
 !--compute enhancement factor due to van der Waals forces
    IF (ok_vdw .EQ. 0) THEN      !--no enhancement factor
-     Evdw=1.0
+      Evdw=1.0
    ELSEIF (ok_vdw .EQ. 1) THEN  !--E(0) case
-     AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radius(i)*radius(j))/(radius(i)+radius(j))**2.
-     xvdW = LOG(1.+AvdWi)
-     EvdW = 1. + avdW1*xvdW + avdW3*xvdW**3
+      AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radiuswet(i)*radiuswet(j))/(radiuswet(i)+radiuswet(j))**2.
+      xvdW = LOG(1.+AvdWi)
+      EvdW = 1. + avdW1*xvdW + avdW3*xvdW**3
    ELSEIF (ok_vdw .EQ. 2) THEN  !--E(infinity) case
-     AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radius(i)*radius(j))/(radius(i)+radius(j))**2.
-     xvdW = LOG(1.+AvdWi)
-     EvdW = 1. + SQRT(AvdWi/3.)/(1.+bvdW0*SQRT(AvdWi)) + bvdW1*xvdW + bvdW3*xvdW**3.
+      AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radiuswet(i)*radiuswet(j))/(radiuswet(i)+radiuswet(j))**2.
+      xvdW = LOG(1.+AvdWi)
+      EvdW = 1. + SQRT(AvdWi/3.)/(1.+bvdW0*SQRT(AvdWi)) + bvdW1*xvdW + bvdW3*xvdW**3.
    ENDIF
 !
@@ -209 +235 @@
   denom=0.0
   DO j=1, nbtr_bin
-  denom=denom+(1.-ff(k,j,k))*beta(k,j)*tr_t(ilon,ilev,j)
+     !    fraction of coagulation of k and j that is not giving k
+     denom=denom+(1.-ff(k,j,k))*beta(k,j)*tr_t(ilon,ilev,j)
   ENDDO
 
@@ -219 +246 @@
     num=0.0
     DO j=1, k
-    numi=0.0
-    DO i=1, k-1
-    numi=numi+ff(i,j,k)*beta(i,j)*V(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
+       numi=0.0
+       DO i=1, k-1
+!           
+!           see Jacobson: " In order to conserve volume and volume concentration (which
+!           coagulation physically does) while giving up some accuracy in number concentration" 
+!
+!           Coagulation of i and j giving k
+!           with V(i) and then V(j) because it considers i,j and j,i with the double loop
+!
+!           BUT WHY WET VOLUME V(i) in old STRATAER? tracers are already dry aerosols and coagulation 
+!           kernel beta(i,j) accounts for wet aerosols -> reply below
+!
+!             numi=numi+ff(i,j,k)*beta(i,j)*V(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
+            numi=numi+ff(i,j,k)*beta(i,j)*Vdry(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
+       ENDDO
+       num=num+numi
     ENDDO
-    num=num+numi
-    ENDDO
 
 !--calculate new concentration of other bins
-    tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/(1.+pdtcoag*denom)/V(k)
+!      tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*V(k) )
+    tr_tp1(ilon,ilev,k)=(Vdry(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*Vdry(k) )
+!
+!       In constant composition (no dependency on aerosol size because no kelvin effect)
+!       V(l)= (f_r_wet(ilon,ilev)**3)*((mdw(l)/2.)**3) = (f_r_wet(ilon,ilev)**3)*Vdry(i)
+!       so numi and num are proportional (f_r_wet(ilon,ilev)**3)
+!       and so 
+!        tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*V(k) )
+!                     =(Vdry(k)*tr_t(ilon,ilev,k)+pdtcoag*num_dry)/( (1.+pdtcoag*denom)*Vdry(k) ) 
+!          with num_dry=...beta(i,j)*Vdry(i)*....
+!       so in old STRATAER (.not.flag_new_strat_compo), it was correct
   ENDIF
 
@@ -234 +282 @@
 !--convert tracer concentration back from [number/m3] to [number/KgA] and write into tr_seri
   DO i=1, nbtr_bin
-   tr_seri(ilon,ilev,i+nbtr_sulgas) = tr_tp1(ilon,ilev,i) / zrho
+     tr_seri(ilon,ilev,i+nbtr_sulgas) = tr_tp1(ilon,ilev,i) / zrho
   ENDDO
 
@@ -240 +288 @@
   ENDDO !--end of loop klev
   ENDDO !--end of loop klon
+! *********************************************
 
 END SUBROUTINE COAGULATE

LMDZ6/branches/cirrus/libf/phylmd/StratAer/cond_evap_tstep_mod.F90

@@ -9 +9 @@
 CONTAINS
 
+      SUBROUTINE condens_evapor_rate_kelvin(R2SO4G,t_seri,pplay,R2SO4, &
+          & DENSO4,f_r_wet,R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
+!
+!     INPUT: 
+!     R2SO4G: number density of gaseous H2SO4 [molecules/cm3]
+!     t_seri: temperature (K)
+!     pplay: pressure (Pa)
+!     R2SO4: aerosol H2SO4 weight fraction (percent) - flat surface (does not depend on aerosol size)
+!     DENSO4: aerosol density (gr/cm3) 
+!     f_r_wet: factor for converting dry to wet radius 
+!        assuming 'flat surface' composition (does not depend on aerosol size)
+!     variables that depends on aerosol size because of Kelvin effect
+!     R2SO4Gik: number density of gaseous H2SO4 [molecules/cm3] - depends on aerosol size
+!     DENSO4ik: aerosol density (gr/cm3) - depends on aerosol size
+!     f_r_wetik: factor for converting dry to wet radius - depends on aerosol size
+!     RRSI: radius [cm]
+
+      USE aerophys
+      USE infotrac_phy
+      USE YOMCST, ONLY : RPI
+      USE sulfate_aer_mod, ONLY : wph2so4, surftension, solh2so4, rpmvh2so4
+      USE strataer_local_var_mod, ONLY : ALPH2SO4, RRSI
+      
+      IMPLICIT NONE
+      
+      REAL, PARAMETER :: third=1./3.
+      
+      ! input variables
+      REAL            :: R2SO4G !H2SO4 number density [molecules/cm3]
+      REAL            :: t_seri
+      REAL            :: pplay
+      REAL            :: R2SO4
+      REAL            :: DENSO4
+      REAL            :: f_r_wet
+      REAL            :: R2SO4ik(nbtr_bin), DENSO4ik(nbtr_bin), f_r_wetik(nbtr_bin)
+      
+      ! output variables
+      REAL            :: FL(nbtr_bin)
+      REAL            :: ASO4(nbtr_bin)
+      REAL            :: DNDR(nbtr_bin)
+      
+      ! local variables
+      INTEGER            :: IK
+      REAL            :: ALPHA,CST
+      REAL            :: WH2(nbtr_bin)
+      REAL            :: RP,VTK,AA,FL1,RKNUD
+      REAL            :: DND
+      REAL            :: ATOT,AH2O
+      REAL            :: RRSI_wet(nbtr_bin)
+      REAL            :: FPATH, WPP, XA, FKELVIN
+      REAL            :: surtens, mvh2so4, temp
+      
+! ///    MOLEC CONDENSATION GROWTH (DUE TO CHANGES IN H2SO4 AND SO H2O)
+!    ------------------------------------------------------------------
+!                                  EXCEPT CN
+!       RK:H2SO4 WEIGHT PERCENT DOESN'T CHANGE
+!     BE CAREFUL,H2SO4 WEIGHT PERCENTAGE
+
+!                   MOLECULAR ACCOMODATION OF H2SO4
+!     H2SO4 accommodation  coefficient [condensation/evaporation]
+      ALPHA = ALPH2SO4
+!      FPLAIR=(2.281238E-5)*TAIR/PAIR
+!     1.E2 (m to cm), 
+      CST=1.E2*2.281238E-5
+!     same expression as in coagulate
+!     in coagulate: mean free path of air (Pruppacher and Klett, 2010, p.417) [m]
+!     mnfrpth=6.6E-8*(1.01325E+5/pplay(ilon,ilev))*(t_seri(ilon,ilev)/293.15)
+!     mnfrpth=2.28E-5*t_seri/pplay
+      
+      temp = min( max(t_seri, 190.), 300.) ! 190K <= temp <= 300K
+      
+      RRSI_wet(:)=RRSI(:)*f_r_wetik(:)
+
+!     Pruppa and Klett
+      FPATH=CST*t_seri/pplay
+    
+!     H2SO4 mass fraction in aerosol
+      WH2(:)=R2SO4ik(:)*1.0E-2
+
+!                               ACTIVITY COEFFICIENT(SEE GIAUQUE,1951)
+!                               AYERS ET AL (1980)
+!                                  (MU-MU0)
+!      RP=-10156.0/t_seri +16.259-(ACTSO4*4.184)/(8.31441*t_seri)
+!                                  DROPLET H2SO4 PRESSURE IN DYN.CM-2
+!      RP=EXP(RP)*1.01325E6/0.086
+!!      RP=EXP(RP)*1.01325E6
+!                                  H2SO4 NUMBER DENSITY NEAR DROPLET
+
+!      DND=RP*6.02E23/(8.31E7*t_seri)
+
+!                                 KELVIN EFFECT FACTOR
+!CK 20160613: bug fix, removed factor 250 (from original code by S. Bekki)
+!!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri*250.0)
+!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri)
+
+!                                  MEAN KINETIC VELOCITY
+!     DYN*CM*K/(K*GR)=(CM/SEC2)*CM
+!                                  IN CM/SEC
+      VTK=SQRT(8.0*BOLZ*t_seri/(RPI*MH2SO4))
+!                                 KELVIN EFFECT FACTOR
+
+!     Loop on bin radius (RRSI in cm)
+      DO IK=1,nbtr_bin
+
+      IF(R2SO4ik(IK) > 0.0) THEN
+
+!       h2so4 mass fraction (0<wpp<1)
+        wpp=R2SO4ik(IK)*1.e-2    
+        xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
+!       equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
+        DND=solh2so4(t_seri,xa)
+!          KELVIN EFFECT:  
+!       surface tension (mN/m=1.e-3.kg/s2) = f(T,h2so4 mole fraction)
+        surtens=surftension(temp,xa)
+!       partial molar volume of h2so4 (cm3.mol-1 =1.e-6.m3.mol-1)
+        mvh2so4= rpmvh2so4(temp,R2SO4ik(IK))
+!       Kelvin factor (MKS)
+        fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2so4/ (1.e-2*RRSI_wet(IK)*rgas*temp) )
+!                              
+        DNDR(IK) =DND*fkelvin
+
+        FL1=RPI*ALPHA*VTK*(R2SO4G-DNDR(IK))
+
+!       TURCO(1979) FOR HNO3:ALH2SO4 CONDENSATION= ALH2SO4 EVAPORATION
+!       RPI*R2*VTK IS EQUIVALENT TO DIFFUSION COEFFICIENT
+!       EXTENSION OF THE RELATION FOR DIFFUSION KINETICS
+!       KNUDSEN NUMBER FPATH/RRSI
+!       NEW VERSION (SEE NOTES)
+        RKNUD=FPATH/RRSI_wet(IK)
+!       SENFELD
+        FL(IK)=FL1*RRSI_wet(IK)**2*( 1.0 +RKNUD ) & 
+     &     /( 1.0 +ALPHA/(2.0*RKNUD) +RKNUD )
+!       TURCO
+!        RL= (4.0/3.0 +0.71/RKNUD)/(1.0+1.0/RKNUD)
+!     *         +4.0*(1.0-ALPHA)/(3.0*ALPHA)
+!        FL=FL1*RRSI(IK)*RRSI(IK)
+!     *         /( (3.0*ALPHA/4.0)*(1.0/RKNUD+RL*ALPHA) )
+
+!                         INITIAL NUMBER OF H2SO4 MOLEC OF 1 DROPLET
+        ATOT=4.0*RPI*DENSO4ik(IK)*(RRSI_wet(IK)**3)/3.0 !attention: g and cm
+        ASO4(IK)=WH2(IK)*ATOT/MH2SO4 !attention: g
+!        ATOT=4.0*RPI*dens_aer(I,J)/1000.*(RRSI(IK)**3)/3.0
+!        ASO4=mfrac_H2SO4*ATOT/MH2SO4
+!                        INITIAL NUMBER OF H2O MOLEC OF 1 DROPLET
+        AH2O=(1.0-WH2(IK))*ATOT/MH2O !attention: g
+
+!       CHANGE OF THE NUMBER OF H2SO4 MOLEC OF 1 DROPLET DURING DT
+!       IT IS FOR KEM BUT THERE ARE OTHER WAYS
+
+      ENDIF  
+
+      ENDDO !loop over bins
+
+      END SUBROUTINE condens_evapor_rate_kelvin
+      
+!********************************************************************
       SUBROUTINE condens_evapor_rate(R2SO4G,t_seri,pplay,ACTSO4,R2SO4, &
-                   & DENSO4,f_r_wet,RRSI,Vbin,FL,ASO4,DNDR)
+                   & DENSO4,f_r_wet,FL,ASO4,DNDR)
 !
 !     INPUT: 
@@ -22 +178 @@
       USE infotrac_phy
       USE YOMCST, ONLY : RPI
+      USE strataer_local_var_mod, ONLY : ALPH2SO4, RRSI
 
       IMPLICIT NONE
@@ -33 +190 @@
       REAL DENSO4
       REAL f_r_wet
-      REAL RRSI(nbtr_bin)
-      REAL Vbin(nbtr_bin)
-
+      
       ! output variables
       REAL FL(nbtr_bin)
@@ -48 +203 @@
       REAL ATOT,AH2O
       REAL RRSI_wet(nbtr_bin)
-      REAL Vbin_wet(nbtr_bin)
-      REAL MH2SO4,MH2O,BOLZ,FPATH
+      REAL FPATH
 
 ! ///    MOLEC CONDENSATION GROWTH (DUE TO CHANGES IN H2SO4 AND SO H2O)
@@ -57 +211 @@
 !     BE CAREFUL,H2SO4 WEIGHT PERCENTAGE
 
-!                   WEIGHT OF 1 MOLEC IN G
-      MH2O  =1000.*mH2Omol !18.016*1.66E-24
-      MH2SO4=1000.*mH2SO4mol !98.082*1.66E-24
-!                   BOLTZMANN CONSTANTE IN DYN.CM/K
-      BOLZ  =1.381E-16
 !                   MOLECULAR ACCOMODATION OF H2SO4
-!     raes and van dingen
-      ALPHA =0.1    
+!     H2SO4 accommodation coefficient [condensation/evaporation]
+      ALPHA = ALPH2SO4
 !      FPLAIR=(2.281238E-5)*TAIR/PAIR
 !     1.E2 (m to cm), 
       CST=1.E2*2.281238E-5
 
-      ! compute local wet particle radius and volume
+      ! compute local wet particle radius [cm]
       RRSI_wet(:)=RRSI(:)*f_r_wet
-      Vbin_wet(:)=Vbin(:)*f_r_wet**3
-
+      
 !     Pruppa and Klett
       FPATH=CST*t_seri/pplay
@@ -138 +286 @@
 
 !********************************************************************
-      SUBROUTINE cond_evap_part(dt,FL,ASO4,f_r_wet,RRSI,Vbin,tr_seri)
+      SUBROUTINE condens_evapor_part(dt,FL,ASO4,f_r_wet,tr_seri)
 
       USE aerophys
       USE infotrac_phy
       USE YOMCST, ONLY : RPI
-
+      USE strataer_local_var_mod, ONLY : RRSI,Vbin
+      
       IMPLICIT NONE
 
@@ -151 +300 @@
       REAL ASO4(nbtr_bin)
       REAL f_r_wet
-      REAL RRSI(nbtr_bin)
-      REAL Vbin(nbtr_bin)
-
+      
       ! output variables
       REAL tr_seri(nbtr)
-
+      
       ! local variables
       REAL tr_seri_new(nbtr)
@@ -211 +358 @@
       tr_seri(:)=tr_seri_new(:)
 
-      END SUBROUTINE cond_evap_part
+      END SUBROUTINE condens_evapor_part
 
 END MODULE cond_evap_tstep_mod

LMDZ6/branches/cirrus/libf/phylmd/StratAer/micphy_tstep.F90

@@ -8 +8 @@
   USE aerophys
   USE infotrac_phy, ONLY : nbtr_bin, nbtr_sulgas, nbtr, id_H2SO4_strat
-  USE phys_local_var_mod, ONLY: mdw, budg_3D_nucl, budg_3D_cond_evap, budg_h2so4_to_part, R2SO4, DENSO4, f_r_wet
+  USE phys_local_var_mod, ONLY: mdw, budg_3D_nucl, budg_3D_cond_evap, budg_h2so4_to_part, R2SO4, DENSO4, &
+       f_r_wet, R2SO4B, DENSO4B, f_r_wetB
   USE nucleation_tstep_mod
   USE cond_evap_tstep_mod
@@ -14 +15 @@
   USE YOMCST, ONLY : RPI, RD, RG
   USE print_control_mod, ONLY: lunout
-  USE strataer_local_var_mod
+  USE strataer_local_var_mod ! contains also RRSI and Vbin
   
   IMPLICIT NONE
@@ -35 +36 @@
   REAL                      :: ntot !total number of molecules in the critical cluster (ntot>4)
   REAL                      :: x    ! molefraction of H2SO4 in the critical cluster     
-  REAL Vbin(nbtr_bin)
   REAL a_xm, b_xm, c_xm
   REAL PDT, dt
   REAL H2SO4_init
   REAL ACTSO4(klon,klev)
-  REAL RRSI(nbtr_bin)
   REAL nucl_rate
   REAL cond_evap_rate
@@ -48 +47 @@
   REAL DNDR(nbtr_bin)
   REAL H2SO4_sat
-
-  DO it=1,nbtr_bin
-    Vbin(it)=4.0*RPI*((mdw(it)/2.)**3)/3.0
-  ENDDO
-
+  REAL R2SO4ik(nbtr_bin), DENSO4ik(nbtr_bin), f_r_wetik(nbtr_bin)
+  
   !coefficients for H2SO4 density parametrization used for nucleation if ntot<4
   a_xm = 0.7681724 + 1.*(2.1847140 + 1.*(7.1630022 + 1.*(-44.31447 + &
@@ -61 +57 @@
        & 1.*(7.990811e-4 + 1.*(-7.458060e-4 + 1.*2.58139e-4 )))))
 
-  ! STRAACT (R2SO4, t_seri -> H2SO4 activity coefficient (ACTSO4)) for cond/evap
-  CALL STRAACT(ACTSO4)
-
-  ! compute particle radius in cm RRSI from diameter in m 
-  DO it=1,nbtr_bin
-    RRSI(it)=mdw(it)/2.*100.
-  ENDDO
-
+  IF(.not.flag_new_strat_compo) THEN
+     ! STRAACT (R2SO4, t_seri -> H2SO4 activity coefficient (ACTSO4)) for cond/evap
+     CALL STRAACT(ACTSO4)
+  ENDIF
+  
   DO ilon=1, klon
 !
@@ -104 +97 @@
       ENDIF
       ! compute cond/evap rate in kg(H2SO4)/kgA/s
-      CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
-             & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
-             & RRSI,Vbin,FL,ASO4,DNDR)
+      IF(flag_new_strat_compo) THEN
+         R2SO4ik(:)   = R2SO4B(ilon,ilev,:)
+         DENSO4ik(:)  = DENSO4B(ilon,ilev,:)
+         f_r_wetik(:) = f_r_wetB(ilon,ilev,:)
+         CALL condens_evapor_rate_kelvin(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+              & R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+              & R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
+      ELSE
+         CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+              & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+              & FL,ASO4,DNDR)
+      ENDIF
       ! Compute H2SO4 saturate vapor for big particules
       H2SO4_sat = DNDR(nbtr_bin)/(pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol)
@@ -127 +129 @@
       tr_seri(ilon,ilev,id_H2SO4_strat)=MAX(0.,tr_seri(ilon,ilev,id_H2SO4_strat)-(nucl_rate+cond_evap_rate)*dt)
       ! apply cond to bins
-      CALL cond_evap_part(dt,FL,ASO4,f_r_wet(ilon,ilev),RRSI,Vbin,tr_seri(ilon,ilev,:))
+      CALL condens_evapor_part(dt,FL,ASO4,f_r_wet(ilon,ilev),tr_seri(ilon,ilev,:))
       ! apply nucl. to bins
-      CALL nucleation_part(nucl_rate,ntot,x,dt,Vbin,tr_seri(ilon,ilev,:))
+      CALL nucleation_part(nucl_rate,ntot,x,dt,tr_seri(ilon,ilev,:))
       ! compute fluxes as diagnostic in [kg(S)/m2/layer/s] (now - for evap and + for cond)
       budg_3D_cond_evap(ilon,ilev)=budg_3D_cond_evap(ilon,ilev)+mSatom/mH2SO4mol &
@@ -142 +144 @@
         & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol
     ! compute cond/evap rate in kg(H2SO4)/kgA/s (now only evap for pdtphys)
-    CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
-           & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
-           & RRSI,Vbin,FL,ASO4,DNDR)
+    IF(flag_new_strat_compo) THEN
+       CALL condens_evapor_rate_kelvin(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+            & R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+            & R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
+    ELSE
+       CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+            & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+            & FL,ASO4,DNDR)
+    ENDIF
     ! limit evaporation (negative FL) over one physics time step to H2SO4 content of the droplet
     DO it=1,nbtr_bin
@@ -159 +167 @@
     tr_seri(ilon,ilev,id_H2SO4_strat)=MAX(0.,tr_seri(ilon,ilev,id_H2SO4_strat)-evap_rate*pdtphys)
     ! apply evap to bins
-    CALL cond_evap_part(pdtphys,FL,ASO4,f_r_wet(ilon,ilev),RRSI,Vbin,tr_seri(ilon,ilev,:))
+    CALL condens_evapor_part(pdtphys,FL,ASO4,f_r_wet(ilon,ilev),tr_seri(ilon,ilev,:))
     ! compute fluxes as diagnostic in [kg(S)/m2/layer/s] (now - for evap and + for cond)
     budg_3D_cond_evap(ilon,ilev)=budg_3D_cond_evap(ilon,ilev)+mSatom/mH2SO4mol &

LMDZ6/branches/cirrus/libf/phylmd/StratAer/miecalc_aer.F90

@@ -16 +16 @@
 
   USE phys_local_var_mod, ONLY: tr_seri, mdw, alpha_bin, piz_bin, cg_bin
-  USE aerophys
+  USE aerophys, ONLY: dens_aer_dry, dens_aer_ref, V_rat
   USE aero_mod
   USE infotrac_phy, ONLY : nbtr, nbtr_bin, nbtr_sulgas, id_SO2_strat
@@ -226 +226 @@
     40000.000,    0.2500,   1.48400,   1.0000E-08, &
     50000.000,    0.2000,   1.49800,   1.0000E-08 /), (/nb_lambda_h2so4,4/), order=(/2,1/) )
-
-  !--initialising dry diameters to geometrically spaced mass/volume (see Jacobson 1994)
-    mdw(1)=mdwmin
-    IF (V_rat.LT.1.62) THEN ! compensate for dip in second bin for lower volume ratio
-      mdw(2)=mdw(1)*2.**(1./3.)
-      DO it=3, nbtr_bin
-        mdw(it)=mdw(it-1)*V_rat**(1./3.)
-      ENDDO 
-    ELSE
-      DO it=2, nbtr_bin
-        mdw(it)=mdw(it-1)*V_rat**(1./3.)
-      ENDDO
-    ENDIF
-    WRITE(lunout,*) 'init mdw=', mdw
-
+     
     !--compute particle radius for a composition of 75% H2SO4 / 25% H2O at T=293K
     DO bin_number=1, nbtr_bin

LMDZ6/branches/cirrus/libf/phylmd/StratAer/nucleation_tstep_mod.F90

@@ -70 +70 @@
 !--------------------------------------------------------------------------------------------------
 
-SUBROUTINE nucleation_part(nucl_rate,ntot,x,dt,Vbin,tr_seri)
+SUBROUTINE nucleation_part(nucl_rate,ntot,x,dt,tr_seri)
 
   USE aerophys
   USE infotrac_phy
-
+  USE strataer_local_var_mod, ONLY : Vbin
+  
   IMPLICIT NONE
 
@@ -82 +83 @@
   REAL x    ! mole raction of H2SO4 in the critical cluster
   REAL dt
-  REAL Vbin(nbtr_bin)
-
+  
   ! output variable
   REAL tr_seri(nbtr)

LMDZ6/branches/cirrus/libf/phylmd/StratAer/strataer_local_var_mod.F90

@@ -51 +51 @@
   
   !============= NUCLEATION VARS =============
+  ! MOLECULAR ACCOMODATION OF H2SO4 (Raes and Van Dingen)
+  REAL,SAVE    :: ALPH2SO4               ! H2SO4 accommodation  coefficient [condensation/evaporation]
+  !$OMP THREADPRIVATE(ALPH2SO4)
+  
   ! flag to constraint nucleation rate in a lat/pres box
   LOGICAL,SAVE :: flag_nuc_rate_box      ! Nucleation rate limit or not to a lat/pres
@@ -64 +68 @@
   INTEGER,SAVE :: flh2o  ! ds stratemit : flh2o =0 (tr_seri), flh2o=1 (dq) 
   !$OMP THREADPRIVATE(flh2o)
-!  REAL,ALLOCATABLE,SAVE    :: d_q_emiss(:,:)
-!  !$OMP THREADPRIVATE(d_q_emiss)
   
   REAL,ALLOCATABLE,SAVE    :: budg_emi(:,:)            !DIMENSION(klon,n)
@@ -144 +146 @@
   !$OMP THREADPRIVATE(day_emit_roc)
   
+  REAL,ALLOCATABLE,SAVE    :: RRSI(:) ! radius [cm] for each aerosol size
+  REAL,ALLOCATABLE,SAVE    :: Vbin(:) ! volume [m3] for each aerosol size  
+  !$OMP THREADPRIVATE(RRSI, Vbin)
   REAL,SAVE    :: dlat, dlon             ! delta latitude and d longitude of grid in degree
   !$OMP THREADPRIVATE(dlat, dlon)
@@ -153 +158 @@
     USE print_control_mod, ONLY : lunout
     USE mod_phys_lmdz_para, ONLY : is_master
-    USE infotrac_phy, ONLY: id_OCS_strat,id_SO2_strat,id_H2SO4_strat,nbtr_sulgas
+    USE infotrac_phy, ONLY: id_OCS_strat,id_SO2_strat,id_H2SO4_strat,nbtr_sulgas,nbtr_bin
+    USE phys_local_var_mod, ONLY : mdw
+    USE aerophys, ONLY: mdwmin, V_rat
+    USE YOMCST  , ONLY : RPI
+    
+    INTEGER :: it
     
     WRITE(lunout,*) 'IN STRATAER_LOCAL_VAR INIT WELCOME!'
@@ -185 +195 @@
     
     ! nuc init
+    ALPH2SO4 = 0.1
     flag_nuc_rate_box = .FALSE.
     nuclat_min=0  ; nuclat_max=0
@@ -238 +249 @@
     ENDIF ! if master
     
+    !--initialising dry diameters to geometrically spaced mass/volume (see Jacobson 1994)
+    mdw(1)=mdwmin
+    IF (V_rat.LT.1.62) THEN ! compensate for dip in second bin for lower volume ratio
+       mdw(2)=mdw(1)*2.**(1./3.)
+       DO it=3, nbtr_bin
+          mdw(it)=mdw(it-1)*V_rat**(1./3.)
+       ENDDO
+    ELSE
+       DO it=2, nbtr_bin
+          mdw(it)=mdw(it-1)*V_rat**(1./3.)
+       ENDDO
+    ENDIF
+    IF (is_master) WRITE(lunout,*) 'init mdw=', mdw
+    
+    !   compute particle radius RRSI [cm] and volume Vbin [m3] from diameter mdw [m]
+    ALLOCATE(RRSI(nbtr_bin), Vbin(nbtr_bin))
+    
+    DO it=1,nbtr_bin
+       !     [cm]
+       RRSI(it)=mdw(it)/2.*100.
+       !     [m3]
+       Vbin(it)=4.0*RPI*((mdw(it)/2.)**3)/3.0
+    ENDDO
+    
+    IF (is_master) THEN
+       WRITE(lunout,*) 'init RRSI=', RRSI
+       WRITE(lunout,*) 'init Vbin=', Vbin
+    ENDIF
+    
     WRITE(lunout,*) 'IN STRATAER INIT END'
     

LMDZ6/branches/cirrus/libf/phylmd/StratAer/strataer_nuc_mod.F90

@@ -13 +13 @@
     USE print_control_mod, ONLY : lunout
     USE mod_phys_lmdz_para, ONLY : is_master
-    USE strataer_local_var_mod, ONLY: flag_nuc_rate_box,nuclat_min,nuclat_max,nucpres_min,nucpres_max
+    USE strataer_local_var_mod, ONLY: ALPH2SO4,flag_nuc_rate_box,nuclat_min,nuclat_max, &
+         nucpres_min,nucpres_max
     
     !Config Key  = flag_nuc_rate_box
@@ -30 +31 @@
     CALL getin_p('nucpres_max',nucpres_max)
     
+    ! Read argument H2SO4 accommodation  coefficient [condensation/evaporation]
+    CALL getin_p('alph2so4',ALPH2SO4)
+    
     !============= Print params =============
     IF (is_master) THEN
+       WRITE(lunout,*) 'IN STRATAER_NUC : ALPH2SO4 = ',alph2so4
        WRITE(lunout,*) 'IN STRATAER_NUC : flag_nuc_rate_box = ',flag_nuc_rate_box
        IF (flag_nuc_rate_box) THEN

LMDZ6/branches/cirrus/libf/phylmd/StratAer/sulfate_aer_mod.F90

@@ -7 +7 @@
 
 !*******************************************************************
-  SUBROUTINE STRACOMP_BIN(sh,t_seri,pplay)
-!
-!   Aerosol H2SO4 weight fraction as a function of PH2O and temperature
-!   INPUT:
-!   sh: VMR of H2O
-!   t_seri: temperature (K)
-!   pplay: middle layer pression (Pa)
-!
-!   OUTPUT:
-!   R2SO4: aerosol H2SO4 weight fraction (percent)
+      SUBROUTINE STRACOMP_KELVIN(sh,t_seri,pplay)
+!
+!     Aerosol H2SO4 weight fraction as a function of PH2O and temperature
+!     INPUT:
+!     sh: MMR of H2O
+!     t_seri: temperature (K)
+!     pplay: middle layer pression (Pa)
+!
+!     Modified in modules:
+!     R2SO4: aerosol H2SO4 weight fraction (percent)
+!     R2SO4B: aerosol H2SO4 weight fraction (percent) for each aerosol bin
+!     DENSO4: aerosol density (gr/cm3)
+!     DENSO4B: aerosol density (gr/cm3)for each aerosol bin
+!     f_r_wet: factor for converting dry to wet radius 
+!        assuming 'flat surface' composition (does not depend on aerosol size)
+!     f_r_wetB: factor for converting dry to wet radius 
+!        assuming 'curved surface' composition (depends on aerosol size)
     
-    USE dimphy, ONLY : klon,klev ! nb of longitude and altitude bands
-    USE aerophys
-    USE phys_local_var_mod, ONLY: R2SO4
+      USE dimphy, ONLY : klon,klev ! nb of longitude and altitude bands
+      USE infotrac_phy, ONLY : nbtr_bin
+      USE aerophys
+      USE phys_local_var_mod, ONLY: R2SO4, R2SO4B, DENSO4, DENSO4B, f_r_wet, f_r_wetB
+      USE strataer_local_var_mod, ONLY: RRSI
+!     WARNING: in phys_local_var_mod R2SO4B, DENSO4B, f_r_wetB (klon,klev,nbtr_bin)
+!          and dens_aer_dry must be declared somewhere
     
-    IMPLICIT NONE
+      IMPLICIT NONE
     
-    REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression in the middle of each layer (Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)          :: sh      ! specific humidity
+      REAL,DIMENSION(klon,klev),INTENT(IN)    :: t_seri  ! Temperature
+      REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay   ! pression in the middle of each layer (Pa)
+      REAL,DIMENSION(klon,klev),INTENT(IN)    :: sh      ! specific humidity (kg h2o/kg air)
+      
+!     local variables
+      integer         :: ilon,ilev,ik
+      real, parameter :: rath2oair = mAIRmol/mH2Omol  
+      real, parameter :: third = 1./3.
+      real            :: pph2ogas(klon,klev) 
+      real            :: temp, wpp, xa, surtens, mvh2o, radwet, fkelvin, pph2okel, r2so4ik, denso4ik
+!----------------------------------------
+  
+!     gas-phase h2o partial pressure (Pa) 
+!                                vmr=sh*rath2oair
+      pph2ogas(:,:) = pplay(:,:)*sh(:,:)*rath2oair
     
-    REAL ks(7)
-    REAL t,qh2o,ptot,pw
-    REAL a,b,c,det
-    REAL xsb,msb
+      DO ilon=1,klon
+      DO ilev=1,klev
+          
+        temp = max(t_seri(ilon,ilev),190.)
+        temp = min(temp,300.)
+
+!    ***   H2SO4-H2O flat surface ***
+!!       equilibrium H2O pressure over pure flat liquid water (Pa)
+!!        pflath2o=psh2o(temp)
+!       h2so4 weight percent(%) = f(P_h2o(Pa),T)
+        R2SO4(ilon,ilev)=wph2so4(pph2ogas(ilon,ilev),temp)  
+!       h2so4 mass fraction (0<wpp<1)
+        wpp=R2SO4(ilon,ilev)*1.e-2     
+!       mole fraction
+        xa=18.*wpp/(18.*wpp+98.*(1.-wpp))
+
+!        CHECK:compare h2so4 sat/ pressure (see Marti et al., 97 & reef. therein)
+!               R2SO4(ilon,ilev)=70.    temp=298.15
+!        equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
+!        include conversion from molec/cm3 to Pa
+!        ph2so4=solh2so4(temp,xa)*(1.38065e-16*temp)/10.
+!        print*,' ph2so4=',ph2so4,temp,R2SO4(ilon,ilev)
+!        good match with Martin, et Ayers, not with Gmitro (the famous 0.086)
+
+!       surface tension (mN/m=1.e-3.kg/s2) = f(T,h2so4 mole fraction)
+        surtens=surftension(temp,xa)
+!       molar volume of pure h2o (cm3.mol-1 =1.e-6.m3.mol-1)
+        mvh2o= rmvh2o(temp)
+!       aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
+        DENSO4(ilon,ilev)=density(temp,wpp) 
+!           ->x1000., to have it in kg/m3
+!       factor for converting dry to wet radius
+        f_r_wet(ilon,ilev) = (dens_aer_dry/(DENSO4(ilon,ilev)*1.e3)/ & 
+                   &    (R2SO4(ilon,ilev)*1.e-2))**third
+!    ***   End of H2SO4-H2O flat surface ***
+
+
+!          Loop on bin radius (RRSI in cm)
+           DO IK=1,nbtr_bin 
+ 
+!      ***   H2SO4-H2O curved surface - Kelvin effect factor ***
+!            wet radius (m) (RRSI(IK) in [cm])
+             if (f_r_wetB(ilon,ilev,IK) .gt. 1.0) then 
+               radwet = 1.e-2*RRSI(IK)*f_r_wetB(ilon,ilev,IK)
+             else 
+!              H2SO4-H2O flat surface, only on the first timestep
+               radwet = 1.e-2*RRSI(IK)*f_r_wet(ilon,ilev)
+             endif
+!            Kelvin factor: 
+!            surface tension (mN/m=1.e-3.kg/s2) 
+!            molar volume of pure h2o (cm3.mol-1 =1.e-6.m3.mol-1)
+             fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2o/ (radwet*rgas*temp) )
+!            equilibrium: pph2o(gas) = pph2o(liq) = pph2o(liq_flat) * fkelvin
+!            equilibrium: pph2o(liq_flat) = pph2o(gas) / fkelvin
+!            h2o liquid partial pressure before Kelvin effect (Pa)
+             pph2okel = pph2ogas(ilon,ilev) / fkelvin
+!            h2so4 weight percent(%) = f(P_h2o(Pa),temp)
+             r2so4ik=wph2so4(pph2okel,temp)
+!            h2so4 mass fraction (0<wpp<1)
+             wpp=r2so4ik*1.e-2    
+!            mole fraction
+             xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
+!            aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
+             denso4ik=density(temp,wpp)
+!           
+!            recalculate Kelvin factor with surface tension and radwet 
+!                              with new R2SO4B and DENSO4B
+             surtens=surftension(temp,xa)
+!            wet radius (m)
+             radwet = 1.e-2*RRSI(IK)*(dens_aer_dry/(denso4ik*1.e3)/ & 
+                   &    (r2so4ik*1.e-2))**third
+             fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2o / (radwet*rgas*temp) ) 
+             pph2okel=pph2ogas(ilon,ilev) / fkelvin
+!            h2so4 weight percent(%) = f(P_h2o(Pa),temp)
+             R2SO4B(ilon,ilev,IK)=wph2so4(pph2okel,temp)
+!            h2so4 mass fraction (0<wpp<1)
+             wpp=R2SO4B(ilon,ilev,IK)*1.e-2    
+             xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
+!            aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
+             DENSO4B(ilon,ilev,IK)=density(temp,wpp)
+!            factor for converting dry to wet radius
+             f_r_wetB(ilon,ilev,IK) = (dens_aer_dry/(DENSO4B(ilon,ilev,IK)*1.e3)/ & 
+                   &    (R2SO4B(ilon,ilev,IK)*1.e-2))**third
+!
+!             print*,'R,Rwet(m),kelvin,h2so4(%),ro=',RRSI(ik),radwet,fkelvin, &
+!              &  R2SO4B(ilon,ilev,IK),DENSO4B(ilon,ilev,IK)
+!             print*,' equil.h2so4(molec/cm3), & 
+!              & sigma',solh2so4(temp,xa),surftension(temp,xa)
+
+           ENDDO
+
+      ENDDO
+      ENDDO
+
+      RETURN
     
-    INTEGER ilon,ilev
-    DATA ks/-21.661,2724.2,51.81,-15732.0,47.004,-6969.0,-4.6183/
-    
-!*******************************************************************
-!***     liquid aerosols process
-!*******************************************************************
-!        BINARIES LIQUID AEROROLS:
-    
-    DO ilon=1,klon
-       DO ilev=1,klev
-          
-          t = max(t_seri(ilon,ilev),185.)
-          qh2o=sh(ilon,ilev)/18.*28.9
-          ptot=pplay(ilon,ilev)/100.
-          pw = qh2o*ptot/1013.0
-          pw = min(pw,2.e-3/1013.)
-          pw = max(pw,2.e-5/1013.)
-          
-!*******************************************************************
-!***     binaries aerosols h2so4/h2o
-!*******************************************************************
-          a = ks(3) + ks(4)/t
-          b = ks(1) + ks(2)/t
-          c = ks(5) + ks(6)/t + ks(7)*log(t) - log(pw)
-          
-          det = b**2 - 4.*a*c
-          
-          IF (det > 0.) THEN
-             xsb = (-b - sqrt(det))/(2.*a)
-             msb = 55.51*xsb/(1.0 - xsb)
-          ELSE
-             msb = 0.
-          ENDIF
-          R2SO4(ilon,ilev) = 100*msb*0.098076/(1.0 + msb*0.098076)
-          
-          ! H2SO4 min dilution: 0.5%
-          R2SO4(ilon,ilev) = max( R2SO4(ilon,ilev), 0.005 )
-       ENDDO
-    ENDDO
-100 RETURN
-    
-  END SUBROUTINE STRACOMP_BIN
-
+  END SUBROUTINE STRACOMP_KELVIN
 !********************************************************************
     SUBROUTINE STRACOMP(sh,t_seri,pplay)
@@ -544 +616 @@
 
     END SUBROUTINE
-
-!****************************************************************
-    SUBROUTINE DENH2SA_TABA(t_seri)
-
-!   AERSOL DENSITY AS A FUNCTION OF H2SO4 WEIGHT PERCENT AND T
-!   from Tabazadeh et al. (1994) abaques
-!   ---------------------------------------------
-
-!   
-!   INPUT: 
-!   R2SO4: aerosol H2SO4 weight fraction (percent)
-!   t_seri: temperature (K)
-!   klon: number of latitude bands in the model domain
-!   klev: number of altitude bands in the model domain
-!   for IFS: perhaps add another dimension for longitude
-!
-!   OUTPUT: 
-!   DENSO4: aerosol mass density (gr/cm3 = aerosol mass/aerosol volume)
-!   
-    USE dimphy, ONLY : klon,klev
-    USE phys_local_var_mod, ONLY: R2SO4, DENSO4
-    
-    IMPLICIT NONE
-    
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-        
-    INTEGER i,j
-    
-!----------------------------------------------------------------------
-!       ... Local variables
-!----------------------------------------------------------------------
-      real, parameter :: a9 = -268.2616e4, a10 = 576.4288e3
-      
-      real :: a0, a1, a2, a3, a4, a5, a6, a7 ,a8
-      real :: c1, c2, c3, c4, w
-      
-      
-!   Loop on model domain (2 dimension for UPMC model; 3 for IFS)
-    DO i=1,klon
-       DO j=1,klev
-!----------------------------------------------------------------------
-!       ... Temperature variables
-!----------------------------------------------------------------------
-          c1 = t_seri(I,J)- 273.15
-          c2 = c1**2
-          c3 = c1*c2
-          c4 = c1*c3
-!----------------------------------------------------------------------
-!       Polynomial Coefficients
-!----------------------------------------------------------------------
-          a0 = 999.8426 + 334.5402e-4*c1 - 569.1304e-5*c2
-          a1 = 547.2659 - 530.0445e-2*c1 + 118.7671e-4*c2 + 599.0008e-6*c3
-          a2 = 526.295e1 + 372.0445e-1*c1 + 120.1909e-3*c2 - 414.8594e-5*c3 + 119.7973e-7*c4
-          a3 = -621.3958e2 - 287.7670*c1 - 406.4638e-3*c2 + 111.9488e-4*c3 + 360.7768e-7*c4
-          a4 = 409.0293e3 + 127.0854e1*c1 + 326.9710e-3*c2 - 137.7435e-4*c3 - 263.3585e-7*c4
-          a5 = -159.6989e4 - 306.2836e1*c1 + 136.6499e-3*c2 + 637.3031e-5*c3
-          a6 = 385.7411e4 + 408.3717e1*c1 - 192.7785e-3*c2
-          a7 = -580.8064e4 - 284.4401e1*c1
-          a8 = 530.1976e4 + 809.1053*c1
-!----------------------------------------------------------------------
-!       ... Summation
-!----------------------------------------------------------------------
-!     w : H2SO4 Weight fraction
-          w=r2SO4(i,j)*0.01
-          DENSO4(i,j) = 0.001*(a0 + w*(a1 + w*(a2 + w*(a3 + w*(a4 +  & 
-               w*(a5 + w*(a6 + w*(a7 + w*(a8 + w*(a9 + w*a10))))))))))
-          DENSO4(i,j) = max (0.0, DENSO4(i,j) )
-
-       ENDDO
-    ENDDO
-
-  END SUBROUTINE DENH2SA_TABA
   
 !****************************************************************
@@ -764 +764 @@
        RETURN
        END SUBROUTINE
-
+!********************************************************************
+!-----------------------------------------------------------------------
+      real function psh2so4(T) result(psh2so4_out)
+!     equilibrium H2SO4 pressure over pure H2SO4 solution (Pa)
+!
+!---->Ayers et.al. (1980), GRL (7) pp 433-436
+!     plus corrections for lower temperatures by Kulmala and Laaksonen (1990)
+!     and Noppel et al. (1990)
+
+      implicit none
+      real, intent(in) :: T
+      real, parameter ::      &
+              &  b1=1.01325e5, &
+              &  b2=11.5,  &
+              &  b3=1.0156e4,  &
+              &  b4=0.38/545., &
+              &  tref=360.15
+
+!     saturation vapor pressure ( N/m2 = Pa = kg/(m.s2) )
+      psh2so4_out=b1*exp(  -b2 +b3*( 1./tref-1./T  &
+           &  +b4*(1.+log(tref/T)-tref/T) )   )  
+
+       return
+    end function psh2so4
+!-----------------------------------------------------------------------
+    real function ndsh2so4(T) result(ndsh2so4_out)
+!     equilibrium H2SO4 number density over pure H2SO4 (molec/cm3)
+
+      implicit none
+      real, intent(in) :: T
+      real :: presat
+
+!     Boltzmann constant ( 1.38065e-23 J/K = m2⋅kg/(s2⋅K) )
+!      akb idem in cm2⋅g/(s2⋅K) 
+      real, parameter :: akb=1.38065e-16
+
+!     pure h2so4 saturation vapor pressure (Pa)
+      presat=psh2so4(T)
+!     saturation number density (1/cm3) - (molec/cm3)
+      ndsh2so4_out=presat*10./(akb*T)
+
+       return
+     end function ndsh2so4
+!-----------------------------------------------------------------------
+     real function psh2o(T) result(psh2o_out)
+!     equilibrium H2O pressure over pure liquid water (Pa)
+!
+      implicit none
+      real, intent(in) :: T
+
+      if(T.gt.229.) then
+!        Preining et al., 1981 (from Kulmala et al., 1998)
+!        saturation vapor pressure (N/m2 = 1 Pa = 1 kg/(m·s2))
+         psh2o_out=exp( 77.34491296  -7235.424651/T &
+             &                 -8.2*log(T) + 5.7133e-3*T )
+      else
+!        Tabazadeh et al., 1997, parameterization for 185<T<260
+!        saturation water vapor partial pressure (mb = hPa =1.E2 kg/(m·s2))
+!        or from Clegg and Brimblecombe , J. Chem. Eng., p43, 1995.
+;
+         psh2o_out=18.452406985 -3505.1578807/T &
+              &    -330918.55082/(T*T)             &
+              &    +12725068.262/(T*T*T)
+!        in Pa
+         psh2o_out=100.*exp(psh2o_out)
+      end if
+!      print*,psh2o_out
+      
+       return
+     end function psh2o
+!-----------------------------------------------------------------------
+     real function density(T,so4mfrac) result(density_out)
+!        calculation of particle density (gr/cm3)
+
+!        requires Temperature (T) and acid mass fraction (so4mfrac)
+!---->Vehkamaeki et al. (2002)
+
+      implicit none
+      real, intent(in) :: T, so4mfrac
+      real, parameter :: &
+           &      a1= 0.7681724,&
+           &      a2= 2.184714, &
+           &      a3= 7.163002, &
+           &      a4=-44.31447, &
+           &      a5= 88.74606, &
+           &      a6=-75.73729, &
+           &      a7= 23.43228
+      real, parameter :: &
+           &      b1= 1.808225e-3, &
+           &      b2=-9.294656e-3, &
+           &      b3=-3.742148e-2, &
+           &      b4= 2.565321e-1, &
+           &      b5=-5.362872e-1, &
+           &      b6= 4.857736e-1, &
+           &      b7=-1.629592e-1
+      real, parameter :: &
+           &      c1=-3.478524e-6, &
+           &      c2= 1.335867e-5, &
+           &      c3= 5.195706e-5, &
+           &      c4=-3.717636e-4, &
+           &      c5= 7.990811e-4, &
+           &      c6=-7.458060e-4, &
+           &      c7= 2.581390e-4
+      real :: a,b,c,so4m2,so4m3,so4m4,so4m5,so4m6
+      
+      so4m2=so4mfrac*so4mfrac
+      so4m3=so4mfrac*so4m2
+      so4m4=so4mfrac*so4m3
+      so4m5=so4mfrac*so4m4
+      so4m6=so4mfrac*so4m5
+
+      a=+a1+a2*so4mfrac+a3*so4m2+a4*so4m3 &
+         &     +a5*so4m4+a6*so4m5+a7*so4m6
+      b=+b1+b2*so4mfrac+b3*so4m2+b4*so4m3 &
+         &     +b5*so4m4+b6*so4m5+b7*so4m6
+      c=+c1+c2*so4mfrac+c3*so4m2+c4*so4m3 &
+         &     +c5*so4m4+c6*so4m5+c7*so4m6
+      density_out=(a+b*T+c*T*T) ! units are gm/cm**3
+
+       return
+     end function density
+!-----------------------------------------------------------------------
+     real function surftension(T,so4frac) result(surftension_out)
+!        calculation of surface tension (mN/meter)
+!        requires Temperature (T) and acid mole fraction (so4frac)
+!---->Vehkamaeki et al. (2002)
+
+      implicit none
+      real,intent(in) :: T, so4frac
+      real :: a,b,so4mfrac,so4m2,so4m3,so4m4,so4m5,so4sig
+      real, parameter :: &
+            &     a1= 0.11864, &
+            &     a2=-0.11651, &
+            &     a3= 0.76852, &
+            &     a4=-2.40909, &
+            &     a5= 2.95434, &
+            &     a6=-1.25852
+      real, parameter :: &
+            &     b1=-1.5709e-4, &
+            &     b2= 4.0102e-4, &
+            &     b3=-2.3995e-3, &
+            &     b4= 7.611235e-3, &
+            &     b5=-9.37386e-3, &
+            &     b6= 3.89722e-3
+      real, parameter :: convfac=1.e3  ! convert from newton/m to dyne/cm
+      real, parameter :: Mw=18.01528, Ma=98.079
+
+!     so4 mass fraction
+      so4mfrac=Ma*so4frac/( Ma*so4frac+Mw*(1.-so4frac) )
+      so4m2=so4mfrac*so4mfrac
+      so4m3=so4mfrac*so4m2
+      so4m4=so4mfrac*so4m3
+      so4m5=so4mfrac*so4m4
+
+      a=+a1+a2*so4mfrac+a3*so4m2+a4*so4m3+a5*so4m4+a6*so4m5
+      b=+b1+b2*so4mfrac+b3*so4m2+b4*so4m3+b5*so4m4+b6*so4m5
+      so4sig=a+b*T
+      surftension_out=so4sig*convfac
+
+       return
+     end function surftension
+!-----------------------------------------------------------------------
+     real function wph2so4(pph2o,T) result(wph2so4_out)
+!     Calculates the equilibrium composition of h2so4 aerosols
+!     as a function of temperature and  H2O pressure, using
+!     the parameterization of Tabazadeh et al., GRL, p1931, 1997.
+!
+!   Parameters
+!
+!    input:
+!      T.....temperature (K)
+!      pph2o..... amhbiant 2o pressure (Pa)
+!
+!    output:
+!      wph2so4......sulfuric acid composition (weight percent wt % h2so4)
+!                     = h2so4 mass fraction*100.
+!
+      implicit none
+      real, intent(in) :: pph2o, T 
+      
+      real :: aw, rh, y1, y2, sulfmolal
+  
+!       psh2o(T): equilibrium H2O pressure over pure liquid water (Pa)
+!       relative humidity 
+        rh=pph2o/psh2o(T)
+!       water activity
+!        aw=min( 0.999,max(1.e-3,rh) )
+        aw=min( 0.999999999,max(1.e-8,rh) ) 
+
+!       composition
+!       calculation of h2so4 molality
+            if(aw .le. 0.05 .and. aw .gt. 0.) then
+               y1=12.372089320*aw**(-0.16125516114) &
+                 &  -30.490657554*aw -2.1133114241
+               y2=13.455394705*aw**(-0.19213122550) &
+                 &  -34.285174607*aw -1.7620073078
+            else if(aw .le. 0.85 .and. aw .gt. 0.05) then
+               y1=11.820654354*aw**(-0.20786404244) &
+                 &  -4.8073063730*aw -5.1727540348
+               y2=12.891938068*aw**(-0.23233847708) &
+                 &  -6.4261237757*aw -4.9005471319
+            else
+               y1=-180.06541028*aw**(-0.38601102592) &
+                 &  -93.317846778*aw +273.88132245
+               y2=-176.95814097*aw**(-0.36257048154) &
+                 &  -90.469744201*aw +267.45509988
+            end if
+!        h2so4 molality (m=moles of h2so4 (solute)/ kg of h2o(solvent))
+         sulfmolal = y1+((T-190.)*(y2-y1)/70.)
+
+!        for a solution containing mh2so4 and mh2o: 
+!        sulfmolal = (mh2so4(gr)/h2so4_molar_mass(gr/mole)) / (mh2o(gr)*1.e-3)
+!        mh2o=1.e3*(mh2so4/Mh2so4)/sulfmolal=1.e3*mh2so4/(Mh2so4*sulfmolal)
+!        h2so4_mass_fraction = mfh2so4 = mh2so4/(mh2o + mh2so4)
+!        mh2o=mh2so4*(1-mfh2so4)/mfh2so4
+!        combining the 2 equations
+!        1.e3*mh2so4/(Mh2so4*sulfmolal) = mh2so4*(1-mfh2so4)/mfh2so4
+!        1.e3/(Mh2so4*sulfmolal) = (1-mfh2so4)/mfh2so4
+!        1000*mfh2so4 = (1-mfh2so4)*Mh2so4*sulfmolal
+!        mfh2so4*(1000.+Mh2so4*sulfmolal) = Mh2so4*sulfmolal
+!        mfh2so4 = Mh2so4*sulfmolal / (1000.+Mh2so4*sulfmolal) 
+!        wph2so4 (% mass fraction)= 100.*Mh2so4*sulfmolal / (1000.+Mh2so4*sulfmolal) 
+!        recall activity of i = a_i = P_i/P_pure_i and 
+!          activity coefficient of i = gamma_i = a_i/X_i (X_i: mole fraction of i)
+!        so  P_i = gamma_i*X_i*P_pure_i
+!        if ideal solution, gamma_i=1, P_i = X_i*P_pure_i
+
+!        h2so4 weight precent
+         wph2so4_out = 9800.*sulfmolal/(98.*sulfmolal+1000.)
+!         print*,rh,pph2o,psh2o(T),vpice(T)
+!         print*,T,aw,sulfmolal,wph2so4_out
+         wph2so4_out = max(wph2so4_out,15.)
+         wph2so4_out = min(wph2so4_out,99.999)
+
+       return
+     end function wph2so4
+!-----------------------------------------------------------------------
+     real function solh2so4(T,xa) result(solh2so4_out)
+!     equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
+
+      implicit none
+      real, intent(in) :: T, xa       ! T(K)  xa(H2SO4 mass fraction)
+      
+      real :: xw, a12,b12, cacta, presat
+      
+      xw=1.0-xa
+
+!     pure h2so4 saturation number density (molec/cm3)
+      presat=ndsh2so4(T)
+!     compute activity of acid 
+      a12=5.672E3 -4.074E6/T +4.421E8/(T*T)
+      b12=1./0.527
+      cacta=10.**(a12*xw*xw/(xw+b12*xa)**2/T)
+!     h2so4 saturation number density over H2SO4/H2O solution (molec/cm3)
+      solh2so4_out=cacta*xa*presat
+
+       return
+     end function solh2so4
+!-----------------------------------------------------------------------      
+     real function rpmvh2so4(T,ws) result(rpmvh2so4_out)
+!     partial molar volume of h2so4 in h2so4/h2o solution (cm3/mole)
+
+      implicit none
+      real, intent(in) :: T, ws
+      real, dimension(22),parameter :: x=(/  &
+       & 2.393284E-02,-4.359335E-05,7.961181E-08,0.0,-0.198716351, &
+       & 1.39564574E-03,-2.020633E-06,0.51684706,-3.0539E-03,4.505475E-06, &
+       & -0.30119511,1.840408E-03,-2.7221253742E-06,-0.11331674116, &
+       & 8.47763E-04,-1.22336185E-06,0.3455282,-2.2111E-03,3.503768245E-06, &
+       & -0.2315332,1.60074E-03,-2.5827835E-06/)
+      
+      real :: w
+
+        w=ws*0.01
+        rpmvh2so4_out=x(5)+x(6)*T+x(7)*T*T+(x(8)+x(9)*T+x(10)*T*T)*w &
+          +(x(11)+x(12)*T+x(13)*T*T)*w*w
+!       h2so4 partial molar volume in h2so4/h2o solution (cm3/mole)
+        rpmvh2so4_out=rpmvh2so4_out*1000.
+        
+       return
+     end function rpmvh2so4
+!-----------------------------------------------------------------------
+     real function rmvh2o(T) result(rmvh2o_out)
+!     molar volume of pure h2o (cm3/mole)
+
+       implicit none
+       real, intent(in) :: T 
+       real, parameter :: x1=2.393284E-02,x2=-4.359335E-05,x3=7.961181E-08
+
+!      1000: L/mole ->  cm3/mole
+!      pure h2o molar volume (cm3/mole)
+       rmvh2o_out=(x1+x2*T+x3*T*T)*1000.
+       
+       return
+     end function rmvh2o
+!
 END MODULE sulfate_aer_mod

LMDZ6/branches/cirrus/libf/phylmd/StratAer/traccoag_mod.F90

@@ -9 +9 @@
        presnivs, xlat, xlon, pphis, pphi, &
        t_seri, pplay, paprs, sh, rh, tr_seri)
-
+    
     USE phys_local_var_mod, ONLY: mdw, R2SO4, DENSO4, f_r_wet, surf_PM25_sulf, & 
-        & budg_emi_ocs, budg_emi_so2, budg_emi_h2so4, budg_emi_part 
-
+        & budg_emi_ocs, budg_emi_so2, budg_emi_h2so4, budg_emi_part, &
+        & R2SO4B, DENSO4B, f_r_wetB, sulfmmr, SAD_sulfate, sulfmmr_mode, nd_mode, reff_sulfate
+    
     USE dimphy
     USE infotrac_phy, ONLY : nbtr_bin, nbtr_sulgas, nbtr, id_SO2_strat
@@ -56 +57 @@
     REAL                                   :: m_aer_emiss_vol_daily ! daily injection mass emission
     REAL                                   :: m_aer               ! aerosol mass
-    INTEGER                                :: it, k, i, ilon, ilev, itime, i_int, ieru
+    INTEGER                                :: it, k, i, j, ilon, ilev, itime, i_int, ieru
     LOGICAL,DIMENSION(klon,klev)           :: is_strato           ! true = above tropopause, false = below
     REAL,DIMENSION(klon,klev)              :: m_air_gridbox       ! mass of air in every grid box [kg]
@@ -82 +83 @@
     INTEGER                                :: injdur_sai          ! injection duration for SAI case [days]
     INTEGER                                :: yr, is_bissext
+    REAL                                   :: samoment2, samoment3! 2nd and 3rd order moments of size distribution
 
     IF (is_mpi_root .AND. flag_verbose_strataer) THEN
@@ -88 +90 @@
     ENDIF
     
+    !   radius [m]
     DO it=1, nbtr_bin
       r_bin(it)=mdw(it)/2.
@@ -117 +120 @@
 
     IF(flag_new_strat_compo) THEN
-       IF(debutphy) WRITE(lunout,*) 'traccoag: USE STRAT COMPO from Tabazadeh 1994', flag_new_strat_compo
-       ! STRACOMP (H2O, P, t_seri -> aerosol composition (R2SO4)) : binary routine (from reprobus)
-       ! H2SO4 mass fraction in aerosol (%) from Tabazadeh et al. (1994).
-       CALL stracomp_bin(sh,t_seri,pplay)
-       
-       ! aerosol density (gr/cm3) - from Tabazadeh
-       CALL denh2sa_taba(t_seri)
+       IF(debutphy) WRITE(lunout,*) 'traccoag: COMPO/DENSITY (Tabazadeh 97) + H2O kelvin effect', flag_new_strat_compo
+       ! STRACOMP (H2O, P, t_seri, R -> R2SO4 + Kelvin effect) : Taba97, Socol, etc...
+       CALL stracomp_kelvin(sh,t_seri,pplay)
     ELSE
-       IF(debutphy) WRITE(lunout,*) 'traccoag: USE STRAT COMPO from Bekki 2D model', flag_new_strat_compo
+       IF(debutphy) WRITE(lunout,*) 'traccoag: COMPO from Bekki 2D model', flag_new_strat_compo
        ! STRACOMP (H2O, P, t_seri -> aerosol composition (R2SO4)) 
        ! H2SO4 mass fraction in aerosol (%)
@@ -132 +131 @@
        ! aerosol density (gr/cm3)
        CALL denh2sa(t_seri)
+       
+       ! compute factor for converting dry to wet radius (for every grid box)
+       f_r_wet(:,:) = (dens_aer_dry/(DENSO4(:,:)*1000.)/(R2SO4(:,:)/100.))**(1./3.)
     ENDIF
     
-! compute factor for converting dry to wet radius (for every grid box)
-    f_r_wet(:,:) = (dens_aer_dry/(DENSO4(:,:)*1000.)/(R2SO4(:,:)/100.))**(1./3.)
-
 !--calculate mass of air in every grid box
     DO ilon=1, klon
@@ -348 +347 @@
     ENDDO
     
+!--compute 
+!     sulfmmr: Sulfate aerosol concentration (dry mixing ratio) (condensed H2SO4 mmr)
+!     SAD_sulfate: SAD all aerosols (cm2/cm3) (must be WET)
+!     sulfmmr_mode: sulfate(=H2SO4 if dry) MMR in different modes (ambiguous but based on sulfmmr, it mus be DRY(?) mmr)
+!     nd_mode: DRY(?) particle concentration in different modes (part/m3)
+     sulfmmr(:,:)=0.0
+     SAD_sulfate(:,:)=0.0
+     sulfmmr_mode(:,:,:)=0.0
+     nd_mode(:,:,:)=0.0
+     reff_sulfate(:,:)=0.0
+     
+     DO i=1,klon
+        DO j=1,klev
+           samoment2=0.0
+           samoment3=0.0
+           DO it=1, nbtr_bin
+              !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) &
+              !assume that particles consist of ammonium sulfate at the surface (132g/mol) 
+              !and are dry at T = 20 deg. C and 50 perc. humidity
+              
+              !     sulfmmr_mode: sulfate(=H2SO4 if dry) MMR in different modes (based on sulfmmr, it must be DRY mmr)
+              !     equivalent to condensed H2SO4 mmr= H2SO4 kg / kgA in bin it
+              sulfmmr_mode(i,j,it) = tr_seri(i,j,it+nbtr_sulgas) &        ! [DRY part/kgA in bin it] 
+                   &  *(4./3.)*RPI*(mdw(it)/2.)**3.   &                   ! [mdw: dry diameter in m] 
+                   &  *dens_aer_dry                                       ! [dry aerosol mass density in kg/m3] 
+              
+              !     sulfmmr: Sulfate aerosol concentration (dry mass mixing ratio) 
+              !     equivalent to total condensed H2SO4 mmr (H2SO4 kg / kgA
+              sulfmmr(i,j) = sulfmmr(i,j) + sulfmmr_mode(i,j,it)
+              
+              !     nd_mode: particle concentration in different modes (DRY part/m3)
+              nd_mode(i,j,it) = tr_seri(i,j,it+nbtr_sulgas) &             ! [DRY part/kgA in bin it] 
+                   & *pplay(i,j)/t_seri(i,j)/RD                           ! [air mass concentration in kg air /m3A]
+              
+              IF(flag_new_strat_compo) THEN
+                 !     SAD_sulfate: SAD WET sulfate aerosols (cm2/cm3)
+                 SAD_sulfate(i,j) = SAD_sulfate(i,j) + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)] 
+                      &  *4.*RPI*( mdw(it)*f_r_wetB(i,j,it)/2. )**2. &       ! [WET SA of part it in m2] 
+                      &  *1.e-2                                              ! conversion from m2/m3 to cm2/cm3A
+!    samoment2 : 2nd order moment of WET sulfate aerosols (m2/m3)
+                 samoment2 = samoment2 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wetB(i,j,it)/2. )**2.                     ! [WET SA of part it in m2]
+!    samoment3 : 3nd order moment of WET sulfate aerosols (cm2/cm3)
+                 samoment3 = samoment3 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wetB(i,j,it)/2. )**3.                     ! [WET SA of part it in m2]
+              ELSE
+!     SAD_sulfate: SAD WET sulfate aerosols (cm2/cm3)
+                 SAD_sulfate(i,j) = SAD_sulfate(i,j) + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)] 
+                      &  *4.*RPI*( mdw(it)*f_r_wet(i,j)/2. )**2. &           ! [WET SA of part it in m2] 
+                      &  *1.e-2                                              ! conversion from m2/m3 to cm2/cm3A
+!    samoment2 : 2nd order moment of WET sulfate aerosols (m2/m3)
+                 samoment2 = samoment2 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wet(i,j)/2. )**2.                          ! [WET SA of part it in m2]
+!    samoment3 : 3nd order moment of WET sulfate aerosols (cm2/cm3)
+                 samoment3 = samoment3 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wet(i,j)/2. )**3.                          ! [WET SA of part it in m2]
+              ENDIF
+           ENDDO
+!     reff_sulfate: effective radius of WET sulfate aerosols (cm)
+           reff_sulfate(i,j) = (samoment3 / samoment2) &
+                & *1.e2                                              ! conversion from m to cm
+        ENDDO
+     ENDDO
+     
   END SUBROUTINE traccoag
 

LMDZ6/branches/cirrus/libf/phylmd/add_phys_tend_mod.F90

@@ -774 +774 @@
       bilh_bnd = (-(rcw-rcpd)*t_seri(1,1) + rlvtt) * rain_lsc(1) &
     &         + (-(rcs-rcpd)*t_seri(1,1) + rlstt) * snow_lsc(1)
-  CASE("bs") param
+  CASE("bsss") param
       bilq_bnd = - bs_fall(1)
       bilh_bnd = (-(rcs-rcpd)*t_seri(1,1) + rlstt) * bs_fall(1)

LMDZ6/branches/cirrus/libf/phylmd/cdrag_mod.F90

@@ -23 +23 @@
 
   USE dimphy
+  USE coare_cp_mod, ONLY: coare_cp
+  USE coare30_flux_cnrm_mod, ONLY: coare30_flux_cnrm
   USE indice_sol_mod
   USE print_control_mod, ONLY: lunout, prt_level
@@ -341 +343 @@
          LPWG    = .false.
          call ini_csts
-         call coare30_flux_cnrm(z_0m,t1(i),tsurf(i), q1(i),  &
-             sqrt(zdu2),zgeop1(i)/RG,zgeop1(i)/RG,psol(i),qsurf(i),PQSAT, &
-             PSFTH,PFSTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI, &
-             PRESA,prain,pat1(i),z_0h, LPRECIP, LPWG, coeffs) 
+         block
+           real, dimension(1) :: z0m_1d, z_0h_1d, sqrt_zdu2_1d, zgeop1_rg_1d  ! convert scalar to 1D for call
+           z0m_1d = z0m
+           z_0h_1d = z0h
+           sqrt_zdu2_1d = sqrt(zdu2)
+           zgeop1_rg_1d=zgeop1(i)/RG
+           call coare30_flux_cnrm(z0m_1d,t1(i),tsurf(i), q1(i),  &
+               sqrt_zdu2_1d,zgeop1_rg_1d,zgeop1_rg_1d,psol(i),qsurf(i),PQSAT, &
+               PSFTH,PFSTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI, &
+               PRESA,prain,pat1(i),z_0h_1d, LPRECIP, LPWG, coeffs)
+
+         end block
          cdmm(i) = coeffs(1)
          cdhh(i) = coeffs(2)

LMDZ6/branches/cirrus/libf/phylmd/clesphys.h

@@ -110 +110 @@
        LOGICAL :: ok_3Deffect
 
+!OB flag to activate water mass fixer in physiq
+       LOGICAL :: ok_water_mass_fixer
+
        COMMON/clesphys/                                                 &
 ! REAL FIRST
@@ -161 +164 @@
      &     , iflag_phytrac, ok_new_lscp, ok_bs, ok_rad_bs               &
      &     ,  iflag_thermals,nsplit_thermals, tau_thermals              &
-     &     , iflag_physiq, ok_3Deffect
+     &     , iflag_physiq, ok_3Deffect, ok_water_mass_fixer
        save /clesphys/
 !$OMP THREADPRIVATE(/clesphys/)

LMDZ6/branches/cirrus/libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.F90

@@ -146 +146 @@
 !  ENDIF
 ENDIF
-CALL writefield_phy('latitude',latitude_deg,1)
-CALL writefield_phy('pressure_hl',pressure_hl,klev+1)
-CALL writefield_phy('Ldecorel',PDECORR_LEN_EDGES_M,klev)
+!CALL writefield_phy('latitude',latitude_deg,1)
+!CALL writefield_phy('pressure_hl',pressure_hl,klev+1)
+!CALL writefield_phy('Ldecorel',PDECORR_LEN_EDGES_M,klev)
 ! -------------------------------------------------------------------
 

LMDZ6/branches/cirrus/libf/phylmd/ecrad/lmdz/radiation_setup.F90

@@ -141 +141 @@
            &  -9, &
            &   4 /)
-!   rad_config%aerosol_optics_override_file_name = 'aerosol_optics_lmdz.nc'
 
 

LMDZ6/branches/cirrus/libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.F90

@@ -4 +4 @@
      flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, &
      pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
-     tr_seri, mass_solu_aero, mass_solu_aero_pi) 
+     tr_seri, mass_solu_aero, mass_solu_aero_pi, m_allaer) 
 !     tau_aero, piz_aero, cg_aero, &
 !     tausum_aero, drytausum_aero, tau3d_aero )
@@ -18 +18 @@
        concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, &
        loadno3,load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7, & 
-       load_tmp8,load_tmp9,load_tmp10,m_allaer
+       load_tmp8,load_tmp9,load_tmp10
 
   USE infotrac_phy, ONLY: tracers, nqtot, nbtr
@@ -49 +49 @@
   REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
   REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
+  REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer
+  ! AI a passer par la suite en argument si besoin pour ecrad
+  !REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer_pi !RAF
+
 !  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
 !  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
@@ -86 +90 @@
   REAL, DIMENSION(klon,klev)   :: nitrinscoarse_pi
   REAL, DIMENSION(klon,klev)   :: pdel, zrho
-!  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer
-  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi !RAF  
+  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi
 
   integer :: id_ASBCM, id_ASPOMM, id_ASSO4M, id_ASMSAM, id_CSSO4M, id_CSMSAM, id_SSSSM

LMDZ6/branches/cirrus/libf/phylmd/ecrad/radiation/radiation_mcica_lw.F90

@@ -18 +18 @@
 !   2017-07-12  R. Hogan  Call fast adding method if only clouds scatter
 !   2017-10-23  R. Hogan  Renamed single-character variables
-
-#include "ecrad_config.h"
 
 module radiation_mcica_lw
@@ -126 +124 @@
     ! Identify clear-sky layers
     logical :: is_clear_sky_layer(nlev)
-
-    ! Temporary storage for more efficient summation
-#ifdef DWD_REDUCTION_OPTIMIZATIONS
-    real(jprb), dimension(nlev+1,2) :: sum_aux
-#else
-    real(jprb) :: sum_up, sum_dn
-#endif
 
     ! Index of the highest cloudy layer
@@ -188 +179 @@
 
       ! Sum over g-points to compute broadband fluxes
-#ifdef DWD_REDUCTION_OPTIMIZATIONS
-      sum_aux(:,:) = 0.0_jprb
-      do jg = 1,ng
-        do jlev = 1,nlev+1
-          sum_aux(jlev,1) = sum_aux(jlev,1) + flux_up_clear(jg,jlev)
-          sum_aux(jlev,2) = sum_aux(jlev,2) + flux_dn_clear(jg,jlev)
-        end do
-      end do
-      flux%lw_up_clear(jcol,:) = sum_aux(:,1)
-      flux%lw_dn_clear(jcol,:) = sum_aux(:,2)
-#else
-      do jlev = 1,nlev+1
-        sum_up = 0.0_jprb
-        sum_dn = 0.0_jprb
-        !$omp simd reduction(+:sum_up, sum_dn)
-        do jg = 1,ng
-          sum_up = sum_up + flux_up_clear(jg,jlev)
-          sum_dn = sum_dn + flux_dn_clear(jg,jlev)
-        end do
-        flux%lw_up_clear(jcol,jlev) = sum_up
-        flux%lw_dn_clear(jcol,jlev) = sum_dn
-      end do
-#endif
-
+      flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1)
+      flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1)
       ! Store surface spectral downwelling fluxes
       flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1)
@@ -310 +279 @@
           else
             ! Clear-sky layer: copy over clear-sky values
-            do jg = 1,ng
-              reflectance(jg,jlev) = ref_clear(jg,jlev)
-              transmittance(jg,jlev) = trans_clear(jg,jlev)
-              source_up(jg,jlev) = source_up_clear(jg,jlev)
-              source_dn(jg,jlev) = source_dn_clear(jg,jlev)
-            end do
+            reflectance(:,jlev) = ref_clear(:,jlev)
+            transmittance(:,jlev) = trans_clear(:,jlev)
+            source_up(:,jlev) = source_up_clear(:,jlev)
+            source_dn(:,jlev) = source_dn_clear(:,jlev)
           end if
         end do
@@ -340 +307 @@
         
         ! Store overcast broadband fluxes
-#ifdef DWD_REDUCTION_OPTIMIZATIONS
-        sum_aux(:,:) = 0._jprb
-        do jg = 1, ng
-          do jlev = 1, nlev+1
-            sum_aux(jlev,1) = sum_aux(jlev,1) + flux_up(jg,jlev)
-            sum_aux(jlev,2) = sum_aux(jlev,2) + flux_dn(jg,jlev)
-          end do
-        end do
-        flux%lw_up(jcol,:) = sum_aux(:,1)
-        flux%lw_dn(jcol,:) = sum_aux(:,2)
-#else
-        do jlev = 1,nlev+1
-          sum_up = 0.0_jprb
-          sum_dn = 0.0_jprb
-          !$omp simd reduction(+:sum_up, sum_dn)
-          do jg = 1,ng
-            sum_up = sum_up + flux_up(jg,jlev)
-            sum_dn = sum_dn + flux_dn(jg,jlev)
-          end do
-          flux%lw_up(jcol,jlev) = sum_up
-          flux%lw_dn(jcol,jlev) = sum_dn
-        end do
-#endif
+        flux%lw_up(jcol,:) = sum(flux_up,1)
+        flux%lw_dn(jcol,:) = sum(flux_dn,1)
 
         ! Cloudy flux profiles currently assume completely overcast
         ! skies; perform weighted average with clear-sky profile
-        do jlev = 1,nlev+1
-          flux%lw_up(jcol,jlev) =  total_cloud_cover *flux%lw_up(jcol,jlev) &
-             &       + (1.0_jprb - total_cloud_cover)*flux%lw_up_clear(jcol,jlev)
-          flux%lw_dn(jcol,jlev) =  total_cloud_cover *flux%lw_dn(jcol,jlev) &
-             &       + (1.0_jprb - total_cloud_cover)*flux%lw_dn_clear(jcol,jlev)
-        end do
+        flux%lw_up(jcol,:) =  total_cloud_cover *flux%lw_up(jcol,:) &
+             &  + (1.0_jprb - total_cloud_cover)*flux%lw_up_clear(jcol,:)
+        flux%lw_dn(jcol,:) =  total_cloud_cover *flux%lw_dn(jcol,:) &
+             &  + (1.0_jprb - total_cloud_cover)*flux%lw_dn_clear(jcol,:)
         ! Store surface spectral downwelling fluxes
         flux%lw_dn_surf_g(:,jcol) = total_cloud_cover*flux_dn(:,nlev+1) &
@@ -391 +335 @@
         ! No cloud in profile and clear-sky fluxes already
         ! calculated: copy them over
-        do jlev = 1,nlev+1
-          flux%lw_up(jcol,jlev) = flux%lw_up_clear(jcol,jlev)
-          flux%lw_dn(jcol,jlev) = flux%lw_dn_clear(jcol,jlev)
-        end do
+        flux%lw_up(jcol,:) = flux%lw_up_clear(jcol,:)
+        flux%lw_dn(jcol,:) = flux%lw_dn_clear(jcol,:)
         flux%lw_dn_surf_g(:,jcol) = flux%lw_dn_surf_clear_g(:,jcol)
         if (config%do_lw_derivatives) then

LMDZ6/branches/cirrus/libf/phylmd/ecrad/radiation/radiation_mcica_sw.F90

@@ -17 +17 @@
 !   2017-04-22  R. Hogan  Store surface fluxes at all g-points
 !   2017-10-23  R. Hogan  Renamed single-character variables
-
-#include "ecrad_config.h"
 
 module radiation_mcica_sw
@@ -121 +119 @@
     ! Total cloud cover output from the cloud generator
     real(jprb) :: total_cloud_cover
-
-    ! Temporary storage for more efficient summation
-#ifdef DWD_REDUCTION_OPTIMIZATIONS
-    real(jprb), dimension(nlev+1,3) :: sum_aux
-#else
-    real(jprb) :: sum_up, sum_dn_diff, sum_dn_dir
-#endif
 
     ! Number of g points
@@ -184 +175 @@
         
         ! Sum over g-points to compute and save clear-sky broadband
-        ! fluxes. Note that the built-in "sum" function is very slow,
-        ! and before being replaced by the alternatives below
-        ! accounted for around 40% of the total cost of this routine.
-#ifdef DWD_REDUCTION_OPTIMIZATIONS
-        ! Optimized summation for the NEC architecture
-        sum_aux(:,:) = 0.0_jprb
-        do jg = 1,ng
-          do jlev = 1,nlev+1
-            sum_aux(jlev,1) = sum_aux(jlev,1) + flux_up(jg,jlev)
-            sum_aux(jlev,2) = sum_aux(jlev,2) + flux_dn_direct(jg,jlev)
-            sum_aux(jlev,3) = sum_aux(jlev,3) + flux_dn_diffuse(jg,jlev)
-          end do
-        end do
-        flux%sw_up_clear(jcol,:) = sum_aux(:,1)
-        flux%sw_dn_clear(jcol,:) = sum_aux(:,2) + sum_aux(:,3)
+        ! fluxes
+        flux%sw_up_clear(jcol,:) = sum(flux_up,1)
         if (allocated(flux%sw_dn_direct_clear)) then
-          flux%sw_dn_direct_clear(jcol,:) = sum_aux(:,2)
+          flux%sw_dn_direct_clear(jcol,:) &
+               &  = sum(flux_dn_direct,1)
+          flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) &
+               &  + flux%sw_dn_direct_clear(jcol,:)
+        else
+          flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) &
+               &  + sum(flux_dn_direct,1)
         end if
-#else
-        ! Optimized summation for the x86-64 architecture
-        do jlev = 1,nlev+1
-          sum_up      = 0.0_jprb
-          sum_dn_diff = 0.0_jprb
-          sum_dn_dir  = 0.0_jprb
-          !$omp simd reduction(+:sum_up, sum_dn_diff, sum_dn_dir)
-          do jg = 1,ng
-            sum_up      = sum_up      + flux_up(jg,jlev)
-            sum_dn_diff = sum_dn_diff + flux_dn_diffuse(jg,jlev)
-            sum_dn_dir  = sum_dn_dir  + flux_dn_direct(jg,jlev)
-          end do
-          flux%sw_up_clear(jcol,jlev) = sum_up
-          flux%sw_dn_clear(jcol,jlev) = sum_dn_diff + sum_dn_dir
-          if (allocated(flux%sw_dn_direct_clear)) then
-            flux%sw_dn_direct_clear(jcol,jlev) = sum_dn_dir
-          end if
-        end do
-#endif
-        
         ! Store spectral downwelling fluxes at surface
-        do jg = 1,ng
-          flux%sw_dn_diffuse_surf_clear_g(jg,jcol) = flux_dn_diffuse(jg,nlev+1)
-          flux%sw_dn_direct_surf_clear_g(jg,jcol)  = flux_dn_direct(jg,nlev+1)
-        end do
+        flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux_dn_diffuse(:,nlev+1)
+        flux%sw_dn_direct_surf_clear_g(:,jcol)  = flux_dn_direct(:,nlev+1)
 
         ! Do cloudy-sky calculation
@@ -287 +249 @@
             else
               ! Clear-sky layer: copy over clear-sky values
-              do jg = 1,ng
-                reflectance(jg,jlev) = ref_clear(jg,jlev)
-                transmittance(jg,jlev) = trans_clear(jg,jlev)
-                ref_dir(jg,jlev) = ref_dir_clear(jg,jlev)
-                trans_dir_diff(jg,jlev) = trans_dir_diff_clear(jg,jlev)
-                trans_dir_dir(jg,jlev) = trans_dir_dir_clear(jg,jlev)
-              end do
+              reflectance(:,jlev) = ref_clear(:,jlev)
+              transmittance(:,jlev) = trans_clear(:,jlev)
+              ref_dir(:,jlev) = ref_dir_clear(:,jlev)
+              trans_dir_diff(:,jlev) = trans_dir_diff_clear(:,jlev)
+              trans_dir_dir(:,jlev) = trans_dir_dir_clear(:,jlev)
             end if
           end do
@@ -304 +264 @@
           
           ! Store overcast broadband fluxes
-#ifdef DWD_REDUCTION_OPTIMIZATIONS
-          sum_aux(:,:) = 0.0_jprb
-          do jg = 1,ng
-            do jlev = 1,nlev+1
-              sum_aux(jlev,1) = sum_aux(jlev,1) + flux_up(jg,jlev)
-              sum_aux(jlev,2) = sum_aux(jlev,2) + flux_dn_direct(jg,jlev)
-              sum_aux(jlev,3) = sum_aux(jlev,3) + flux_dn_diffuse(jg,jlev)
-            end do
-          end do
-          flux%sw_up(jcol,:) = sum_aux(:,1)
-          flux%sw_dn(jcol,:) = sum_aux(:,2) + sum_aux(:,3)
+          flux%sw_up(jcol,:) = sum(flux_up,1)
           if (allocated(flux%sw_dn_direct)) then
-            flux%sw_dn_direct(jcol,:) = sum_aux(:,2)
+            flux%sw_dn_direct(jcol,:) = sum(flux_dn_direct,1)
+            flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) &
+                 &  + flux%sw_dn_direct(jcol,:)
+          else
+            flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) &
+                 &  + sum(flux_dn_direct,1)
           end if
-#else
-          do jlev = 1,nlev+1
-            sum_up      = 0.0_jprb
-            sum_dn_diff = 0.0_jprb
-            sum_dn_dir  = 0.0_jprb
-            !$omp simd reduction(+:sum_up, sum_dn_diff, sum_dn_dir)
-            do jg = 1,ng
-              sum_up      = sum_up      + flux_up(jg,jlev)
-              sum_dn_diff = sum_dn_diff + flux_dn_diffuse(jg,jlev)
-              sum_dn_dir  = sum_dn_dir  + flux_dn_direct(jg,jlev)
-            end do
-            flux%sw_up(jcol,jlev) = sum_up
-            flux%sw_dn(jcol,jlev) = sum_dn_diff + sum_dn_dir
-            if (allocated(flux%sw_dn_direct)) then
-              flux%sw_dn_direct(jcol,jlev) = sum_dn_dir
-            end if
-          end do
-#endif
-          
+
           ! Cloudy flux profiles currently assume completely overcast
           ! skies; perform weighted average with clear-sky profile
-          do jlev = 1, nlev+1
-            flux%sw_up(jcol,jlev) =  total_cloud_cover *flux%sw_up(jcol,jlev) &
-                 &     + (1.0_jprb - total_cloud_cover)*flux%sw_up_clear(jcol,jlev)
-            flux%sw_dn(jcol,jlev) =  total_cloud_cover *flux%sw_dn(jcol,jlev) &
-                 &     + (1.0_jprb - total_cloud_cover)*flux%sw_dn_clear(jcol,jlev)
-            if (allocated(flux%sw_dn_direct)) then
-              flux%sw_dn_direct(jcol,jlev) = total_cloud_cover *flux%sw_dn_direct(jcol,jlev) &
-                   &  + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_clear(jcol,jlev)
-            end if
-          end do
+          flux%sw_up(jcol,:) =  total_cloud_cover *flux%sw_up(jcol,:) &
+               &  + (1.0_jprb - total_cloud_cover)*flux%sw_up_clear(jcol,:)
+          flux%sw_dn(jcol,:) =  total_cloud_cover *flux%sw_dn(jcol,:) &
+               &  + (1.0_jprb - total_cloud_cover)*flux%sw_dn_clear(jcol,:)
+          if (allocated(flux%sw_dn_direct)) then
+            flux%sw_dn_direct(jcol,:) = total_cloud_cover *flux%sw_dn_direct(jcol,:) &
+                 &  + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_clear(jcol,:)
+          end if
           ! Likewise for surface spectral fluxes
-          do jg = 1,ng
-            flux%sw_dn_diffuse_surf_g(jg,jcol) = flux_dn_diffuse(jg,nlev+1)
-            flux%sw_dn_direct_surf_g(jg,jcol)  = flux_dn_direct(jg,nlev+1)
-            flux%sw_dn_diffuse_surf_g(jg,jcol) = total_cloud_cover *flux%sw_dn_diffuse_surf_g(jg,jcol) &
-                 &                 + (1.0_jprb - total_cloud_cover)*flux%sw_dn_diffuse_surf_clear_g(jg,jcol)
-            flux%sw_dn_direct_surf_g(jg,jcol)  = total_cloud_cover *flux%sw_dn_direct_surf_g(jg,jcol) &
-                 &                 + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_surf_clear_g(jg,jcol)
-          end do
-
+          flux%sw_dn_diffuse_surf_g(:,jcol) = flux_dn_diffuse(:,nlev+1)
+          flux%sw_dn_direct_surf_g(:,jcol)  = flux_dn_direct(:,nlev+1)
+          flux%sw_dn_diffuse_surf_g(:,jcol) = total_cloud_cover *flux%sw_dn_diffuse_surf_g(:,jcol) &
+               &     + (1.0_jprb - total_cloud_cover)*flux%sw_dn_diffuse_surf_clear_g(:,jcol)
+          flux%sw_dn_direct_surf_g(:,jcol) = total_cloud_cover *flux%sw_dn_direct_surf_g(:,jcol) &
+               &     + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_surf_clear_g(:,jcol)
+          
         else
           ! No cloud in profile and clear-sky fluxes already
           ! calculated: copy them over
-          do jlev = 1, nlev+1
-            flux%sw_up(jcol,jlev) = flux%sw_up_clear(jcol,jlev)
-            flux%sw_dn(jcol,jlev) = flux%sw_dn_clear(jcol,jlev)
-            if (allocated(flux%sw_dn_direct)) then
-              flux%sw_dn_direct(jcol,jlev) = flux%sw_dn_direct_clear(jcol,jlev)
-            end if
-          end do
-          do jg = 1,ng
-            flux%sw_dn_diffuse_surf_g(jg,jcol) = flux%sw_dn_diffuse_surf_clear_g(jg,jcol)
-            flux%sw_dn_direct_surf_g(jg,jcol)  = flux%sw_dn_direct_surf_clear_g(jg,jcol)
-          end do
+          flux%sw_up(jcol,:) = flux%sw_up_clear(jcol,:)
+          flux%sw_dn(jcol,:) = flux%sw_dn_clear(jcol,:)
+          if (allocated(flux%sw_dn_direct)) then
+            flux%sw_dn_direct(jcol,:) = flux%sw_dn_direct_clear(jcol,:)
+          end if
+          flux%sw_dn_diffuse_surf_g(:,jcol) = flux%sw_dn_diffuse_surf_clear_g(:,jcol)
+          flux%sw_dn_direct_surf_g(:,jcol)  = flux%sw_dn_direct_surf_clear_g(:,jcol)
 
         end if ! Cloud is present in profile
@@ -378 +307 @@
       else
         ! Set fluxes to zero if sun is below the horizon
-        do jlev = 1, nlev+1
-          flux%sw_up(jcol,jlev) = 0.0_jprb
-          flux%sw_dn(jcol,jlev) = 0.0_jprb
-          if (allocated(flux%sw_dn_direct)) then
-            flux%sw_dn_direct(jcol,jlev) = 0.0_jprb
-          end if
-          flux%sw_up_clear(jcol,jlev) = 0.0_jprb
-          flux%sw_dn_clear(jcol,jlev) = 0.0_jprb
-          if (allocated(flux%sw_dn_direct_clear)) then
-            flux%sw_dn_direct_clear(jcol,jlev) = 0.0_jprb
-          end if
-        end do
-        do jg = 1,ng
-          flux%sw_dn_diffuse_surf_g(jg,jcol) = 0.0_jprb
-          flux%sw_dn_direct_surf_g(jg,jcol)  = 0.0_jprb
-          flux%sw_dn_diffuse_surf_clear_g(jg,jcol) = 0.0_jprb
-          flux%sw_dn_direct_surf_clear_g(jg,jcol)  = 0.0_jprb
-        end do
+        flux%sw_up(jcol,:) = 0.0_jprb
+        flux%sw_dn(jcol,:) = 0.0_jprb
+        if (allocated(flux%sw_dn_direct)) then
+          flux%sw_dn_direct(jcol,:) = 0.0_jprb
+        end if
+        flux%sw_up_clear(jcol,:) = 0.0_jprb
+        flux%sw_dn_clear(jcol,:) = 0.0_jprb
+        if (allocated(flux%sw_dn_direct_clear)) then
+          flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb
+        end if
+        flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb
+        flux%sw_dn_direct_surf_g(:,jcol)  = 0.0_jprb
+        flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb
+        flux%sw_dn_direct_surf_clear_g(:,jcol)  = 0.0_jprb
       end if ! Sun above horizon
 

LMDZ6/branches/cirrus/libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90

@@ -170 +170 @@
     logical :: is_clear_sky_layer(0:nlev+1)
 
-    ! Temporaries to speed up summations
-    real(jprb) :: sum_dn, sum_up
-    
     ! Index of the highest cloudy layer
     integer :: i_cloud_top
@@ -264 +261 @@
       if (config%do_clear) then
         ! Sum over g-points to compute broadband fluxes
-        do jlev = 1,nlev+1
-          sum_up = 0.0_jprb
-          sum_dn = 0.0_jprb
-          !$omp simd reduction(+:sum_up, sum_dn)
-          do jg = 1,ng
-            sum_up = sum_up + flux_up_clear(jg,jlev)
-            sum_dn = sum_dn + flux_dn_clear(jg,jlev)
-          end do
-          flux%lw_up_clear(jcol,jlev) = sum_up
-          flux%lw_dn_clear(jcol,jlev) = sum_dn
-        end do
-
+        flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1)
+        flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1)
         ! Store surface spectral downwelling fluxes / TOA upwelling
-        do jg = 1,ng
-          flux%lw_dn_surf_clear_g(jg,jcol) = flux_dn_clear(jg,nlev+1)
-          flux%lw_up_toa_clear_g (jg,jcol) = flux_up_clear(jg,1)
-        end do
+        flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1)
+        flux%lw_up_toa_clear_g (:,jcol) = flux_up_clear(:,1)
         ! Save the spectral fluxes if required
         if (config%do_save_spectral_flux) then
@@ -468 +453 @@
           end if
         else
-          sum_dn = 0.0_jprb
-          !$omp simd reduction(+:sum_dn)
-          do jg = 1,ng
-            sum_dn = sum_dn + flux_dn_clear(jg,jlev)
-          end do
-          flux%lw_dn(jcol,jlev) = sum_dn
+          flux%lw_dn(jcol,:) = sum(flux_dn_clear(:,jlev))
           if (config%do_save_spectral_flux) then
             call indexed_sum(flux_dn_clear(:,jlev), &
@@ -490 +470 @@
            &  + total_albedo(:,1,i_cloud_top)*flux_dn_clear(:,i_cloud_top)
       flux_up(:,2:) = 0.0_jprb
-
-      sum_up = 0.0_jprb
-      !$omp simd reduction(+:sum_up)
-      do jg = 1,ng
-        sum_up = sum_up + flux_up(jg,1)
-      end do
-      flux%lw_up(jcol,i_cloud_top) = sum_up
-
+      flux%lw_up(jcol,i_cloud_top) = sum(flux_up(:,1))
       if (config%do_save_spectral_flux) then
         call indexed_sum(flux_up(:,1), &
@@ -505 +478 @@
       do jlev = i_cloud_top-1,1,-1
         flux_up(:,1) = trans_clear(:,jlev)*flux_up(:,1) + source_up_clear(:,jlev)
-        sum_up = 0.0_jprb
-        !$omp simd reduction(+:sum_up)
-        do jg = 1,ng
-          sum_up = sum_up + flux_up(jg,1)
-        end do
-        flux%lw_up(jcol,jlev) = sum_up
+        flux%lw_up(jcol,jlev) = sum(flux_up(:,1))
         if (config%do_save_spectral_flux) then
           call indexed_sum(flux_up(:,1), &
@@ -560 +528 @@
 
         ! Store the broadband fluxes
-        sum_up = 0.0_jprb
-        sum_dn = 0.0_jprb
-        do jreg = 1,nregions
-          !$omp simd reduction(+:sum_up, sum_dn)
-          do jg = 1,ng
-            sum_up = sum_up + flux_up(jg,jreg)
-            sum_dn = sum_dn + flux_dn(jg,jreg)
-          end do
-        end do
-        flux%lw_up(jcol,jlev+1) = sum_up
-        flux%lw_dn(jcol,jlev+1) = sum_dn
+        flux%lw_up(jcol,jlev+1) = sum(sum(flux_up,1))
+        flux%lw_dn(jcol,jlev+1) = sum(sum(flux_dn,1))
 
         ! Save the spectral fluxes if required

LMDZ6/branches/cirrus/libf/phylmd/ecrad/radiation/radiation_tripleclouds_lw.F90.or

@@ -170 +170 @@
     logical :: is_clear_sky_layer(0:nlev+1)
 
+    ! Temporaries to speed up summations
+    real(jprb) :: sum_dn, sum_up
+    
     ! Index of the highest cloudy layer
     integer :: i_cloud_top
@@ -249 +252 @@
         call calc_ref_trans_lw(ng*nlev, &
              &  od(:,:,jcol), ssa(:,:,jcol), g(:,:,jcol), &
-             &  planck_hl(:,1:jlev,jcol), planck_hl(:,2:jlev+1,jcol), &
+             &  planck_hl(:,1:nlev,jcol), planck_hl(:,2:nlev+1,jcol), &
              &  ref_clear, trans_clear, &
              &  source_up_clear, source_dn_clear)
@@ -261 +264 @@
       if (config%do_clear) then
         ! Sum over g-points to compute broadband fluxes
-        flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1)
-        flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1)
+        do jlev = 1,nlev+1
+          sum_up = 0.0_jprb
+          sum_dn = 0.0_jprb
+          !$omp simd reduction(+:sum_up, sum_dn)
+          do jg = 1,ng
+            sum_up = sum_up + flux_up_clear(jg,jlev)
+            sum_dn = sum_dn + flux_dn_clear(jg,jlev)
+          end do
+          flux%lw_up_clear(jcol,jlev) = sum_up
+          flux%lw_dn_clear(jcol,jlev) = sum_dn
+        end do
+
         ! Store surface spectral downwelling fluxes / TOA upwelling
-        flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1)
-        flux%lw_up_toa_clear_g (:,jcol) = flux_up_clear(:,1)
+        do jg = 1,ng
+          flux%lw_dn_surf_clear_g(jg,jcol) = flux_dn_clear(jg,nlev+1)
+          flux%lw_up_toa_clear_g (jg,jcol) = flux_up_clear(jg,1)
+        end do
         ! Save the spectral fluxes if required
         if (config%do_save_spectral_flux) then
@@ -453 +468 @@
           end if
         else
-          flux%lw_dn(jcol,:) = sum(flux_dn_clear(:,jlev))
+          sum_dn = 0.0_jprb
+          !$omp simd reduction(+:sum_dn)
+          do jg = 1,ng
+            sum_dn = sum_dn + flux_dn_clear(jg,jlev)
+          end do
+          flux%lw_dn(jcol,jlev) = sum_dn
           if (config%do_save_spectral_flux) then
             call indexed_sum(flux_dn_clear(:,jlev), &
@@ -470 +490 @@
            &  + total_albedo(:,1,i_cloud_top)*flux_dn_clear(:,i_cloud_top)
       flux_up(:,2:) = 0.0_jprb
-      flux%lw_up(jcol,i_cloud_top) = sum(flux_up(:,1))
+
+      sum_up = 0.0_jprb
+      !$omp simd reduction(+:sum_up)
+      do jg = 1,ng
+        sum_up = sum_up + flux_up(jg,1)
+      end do
+      flux%lw_up(jcol,i_cloud_top) = sum_up
+
       if (config%do_save_spectral_flux) then
         call indexed_sum(flux_up(:,1), &
@@ -478 +505 @@
       do jlev = i_cloud_top-1,1,-1
         flux_up(:,1) = trans_clear(:,jlev)*flux_up(:,1) + source_up_clear(:,jlev)
-        flux%lw_up(jcol,jlev) = sum(flux_up(:,1))
+        sum_up = 0.0_jprb
+        !$omp simd reduction(+:sum_up)
+        do jg = 1,ng
+          sum_up = sum_up + flux_up(jg,1)
+        end do
+        flux%lw_up(jcol,jlev) = sum_up
         if (config%do_save_spectral_flux) then
           call indexed_sum(flux_up(:,1), &
@@ -528 +560 @@
 
         ! Store the broadband fluxes
-        flux%lw_up(jcol,jlev+1) = sum(sum(flux_up,1))
-        flux%lw_dn(jcol,jlev+1) = sum(sum(flux_dn,1))
+        sum_up = 0.0_jprb
+        sum_dn = 0.0_jprb
+        do jreg = 1,nregions
+          !$omp simd reduction(+:sum_up, sum_dn)
+          do jg = 1,ng
+            sum_up = sum_up + flux_up(jg,jreg)
+            sum_dn = sum_dn + flux_dn(jg,jreg)
+          end do
+        end do
+        flux%lw_up(jcol,jlev+1) = sum_up
+        flux%lw_dn(jcol,jlev+1) = sum_dn
 
         ! Save the spectral fluxes if required

LMDZ6/branches/cirrus/libf/phylmd/ecrad/radiation/radiation_tripleclouds_sw.F90

@@ -74 +74 @@
     ! Gas and aerosol optical depth, single-scattering albedo and
     ! asymmetry factor at each shortwave g-point
-    real(jprb), intent(in), dimension(config%n_g_sw,nlev,istartcol:iendcol) &
-         &  :: od, ssa, g
+!    real(jprb), intent(in), dimension(istartcol:iendcol,nlev,config%n_g_sw) :: &
+    real(jprb), intent(in), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: &
+         &  od, ssa, g
 
     ! Cloud and precipitation optical depth, single-scattering albedo and
     ! asymmetry factor in each shortwave band
-    real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) &
-         &  :: od_cloud, ssa_cloud, g_cloud
+    real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: &
+         &  od_cloud, ssa_cloud, g_cloud
 
     ! Optical depth, single scattering albedo and asymmetry factor in
@@ -91 +92 @@
     ! flux into a plane perpendicular to the incoming radiation at
     ! top-of-atmosphere in each of the shortwave g points
-    real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) &
-         &  :: albedo_direct, albedo_diffuse, incoming_sw
+    real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: &
+         &  albedo_direct, albedo_diffuse, incoming_sw
 
     ! Output
@@ -165 +166 @@
     real(jprb) :: scat_od, scat_od_cloud
 
-    ! Temporaries to speed up summations
-    real(jprb) :: sum_dn_diff, sum_dn_dir, sum_up
-
-    ! Local cosine of solar zenith angle
     real(jprb) :: mu0
 
@@ -447 +444 @@
       end if
       
-      ! Store the TOA broadband fluxes, noting that there is no
-      ! diffuse downwelling at TOA. The intrinsic "sum" command has
-      ! been found to be very slow; better performance is found on
-      ! x86-64 architecture with explicit loops and the "omp simd
-      ! reduction" directive.
-      sum_up     = 0.0_jprb
-      sum_dn_dir = 0.0_jprb
-      do jreg = 1,nregions
-        !$omp simd reduction(+:sum_up, sum_dn_dir)
-        do jg = 1,ng
-          sum_up     = sum_up     + flux_up(jg,jreg)
-          sum_dn_dir = sum_dn_dir + direct_dn(jg,jreg)
-        end do
-      end do
-      flux%sw_up(jcol,1) = sum_up
-      flux%sw_dn(jcol,1) = mu0 * sum_dn_dir
+      ! Store the TOA broadband fluxes
+      flux%sw_up(jcol,1) = sum(sum(flux_up,1))
+      flux%sw_dn(jcol,1) = mu0 * sum(sum(direct_dn,1))
       if (allocated(flux%sw_dn_direct)) then
         flux%sw_dn_direct(jcol,1) = flux%sw_dn(jcol,1)
       end if
       if (config%do_clear) then
-        sum_up     = 0.0_jprb
-        sum_dn_dir = 0.0_jprb
-        !$omp simd reduction(+:sum_up, sum_dn_dir)
-        do jg = 1,ng
-          sum_up     = sum_up     + flux_up_clear(jg)
-          sum_dn_dir = sum_dn_dir + direct_dn_clear(jg)
-        end do
-        flux%sw_up_clear(jcol,1) = sum_up
-        flux%sw_dn_clear(jcol,1) = mu0 * sum_dn_dir
+        flux%sw_up_clear(jcol,1) = sum(flux_up_clear)
+        flux%sw_dn_clear(jcol,1) = mu0 * sum(direct_dn_clear)
         if (allocated(flux%sw_dn_direct_clear)) then
           flux%sw_dn_direct_clear(jcol,1) = flux%sw_dn_clear(jcol,1)
@@ -490 +467 @@
              &           config%i_spec_from_reordered_g_sw, &
              &           flux%sw_dn_band(:,jcol,1))
-        flux%sw_dn_band(:,jcol,1) = mu0 * flux%sw_dn_band(:,jcol,1)
+        flux%sw_dn_band(:,jcol,1) = &
+             &  mu0 * flux%sw_dn_band(:,jcol,1)
         if (allocated(flux%sw_dn_direct_band)) then
           flux%sw_dn_direct_band(:,jcol,1) = flux%sw_dn_band(:,jcol,1)
@@ -571 +549 @@
                ! nothing to do
 
-        ! Store the broadband fluxes. The intrinsic "sum" command has
-        ! been found to be very slow; better performance is found on
-        ! x86-64 architecture with explicit loops and the "omp simd
-        ! reduction" directive.
-        sum_up      = 0.0_jprb
-        sum_dn_dir  = 0.0_jprb
-        sum_dn_diff = 0.0_jprb
-        do jreg = 1,nregions
-          !$omp simd reduction(+:sum_up, sum_dn_diff, sum_dn_dir)
-          do jg = 1,ng
-            sum_up      = sum_up      + flux_up(jg,jreg)
-            sum_dn_diff = sum_dn_diff + flux_dn(jg,jreg)
-            sum_dn_dir  = sum_dn_dir  + direct_dn(jg,jreg)
-          end do
-        end do
-        flux%sw_up(jcol,jlev+1) = sum_up
-        flux%sw_dn(jcol,jlev+1) = mu0 * sum_dn_dir + sum_dn_diff
+        ! Store the broadband fluxes
+        flux%sw_up(jcol,jlev+1) = sum(sum(flux_up,1))
         if (allocated(flux%sw_dn_direct)) then
-          flux%sw_dn_direct(jcol,jlev+1) = mu0 * sum_dn_dir
+          flux%sw_dn_direct(jcol,jlev+1) = mu0 * sum(sum(direct_dn,1))
+          flux%sw_dn(jcol,jlev+1) &
+               &  = flux%sw_dn_direct(jcol,jlev+1) + sum(sum(flux_dn,1))
+        else
+          flux%sw_dn(jcol,jlev+1) = mu0 * sum(sum(direct_dn,1)) + sum(sum(flux_dn,1))   
         end if
         if (config%do_clear) then
-          sum_up      = 0.0_jprb
-          sum_dn_dir  = 0.0_jprb
-          sum_dn_diff = 0.0_jprb
-          !$omp simd reduction(+:sum_up, sum_dn_diff, sum_dn_dir)
-          do jg = 1,ng
-            sum_up      = sum_up      + flux_up_clear(jg)
-            sum_dn_diff = sum_dn_diff + flux_dn_clear(jg)
-            sum_dn_dir  = sum_dn_dir  + direct_dn_clear(jg)
-          end do
-          flux%sw_up_clear(jcol,jlev+1) = sum_up
-          flux%sw_dn_clear(jcol,jlev+1) = mu0 * sum_dn_dir + sum_dn_diff
+          flux%sw_up_clear(jcol,jlev+1) = sum(flux_up_clear)
           if (allocated(flux%sw_dn_direct_clear)) then
-            flux%sw_dn_direct_clear(jcol,jlev+1) = mu0 * sum_dn_dir
+            flux%sw_dn_direct_clear(jcol,jlev+1) = mu0 * sum(direct_dn_clear)
+            flux%sw_dn_clear(jcol,jlev+1) &
+                 &  = flux%sw_dn_direct_clear(jcol,jlev+1) + sum(flux_dn_clear)
+          else
+            flux%sw_dn_clear(jcol,jlev+1) = mu0 * sum(direct_dn_clear) &
+                 &  + sum(flux_dn_clear)
           end if
         end if
@@ -643 +605 @@
           end if
         end if
+
       end do ! Final loop over levels
       

LMDZ6/branches/cirrus/libf/phylmd/fonte_neige_mod.F90

@@ -36 +36 @@
   REAL, ALLOCATABLE, DIMENSION(:)             :: runofflic_global
   !$OMP THREADPRIVATE(runofflic_global)
+#ifdef ISO
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: xtrun_off_ter
+  !$OMP THREADPRIVATE(xtrun_off_ter)
+  REAL, ALLOCATABLE, DIMENSION(:,:)           :: xtrun_off_lic
+  !$OMP THREADPRIVATE(xtrun_off_lic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: xtrun_off_lic_0 
+  !$OMP THREADPRIVATE(xtrun_off_lic_0)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE:: fxtfonte_global
+  !$OMP THREADPRIVATE(fxtfonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE:: fxtcalving_global
+  !$OMP THREADPRIVATE(fxtcalving_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: xtrunofflic_global
+  !$OMP THREADPRIVATE(xtrunofflic_global)
+#endif
 
 CONTAINS
@@ -123 +137 @@
 
   END SUBROUTINE fonte_neige_init
+
+#ifdef ISO
+  SUBROUTINE fonte_neige_init_iso(xtrestart_runoff)
+
+! This subroutine allocates and initialize variables in the module. 
+! The variable run_off_lic_0 is initialized to the field read from
+! restart file. The other variables are initialized to zero.
+
+    USE infotrac_phy, ONLY: niso
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,iso_HDO
+    USE isotopes_verif_mod
+#endif
+!
+!****************************************************************************************
+! Input argument
+    REAL, DIMENSION(niso,klon), INTENT(IN) :: xtrestart_runoff 
+
+! Local variables
+    INTEGER                           :: error
+    CHARACTER (len = 80)              :: abort_message 
+    CHARACTER (len = 20)              :: modname = 'fonte_neige_init'
+    INTEGER                           :: i
+
+
+!****************************************************************************************
+! Allocate run-off at landice and initilize with field read from restart
+!
+!****************************************************************************************
+
+    ALLOCATE(xtrun_off_lic_0(niso,klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF    
+    
+    xtrun_off_lic_0(:,:) = xtrestart_runoff(:,:)        
+
+#ifdef ISOVERIF 
+      IF (iso_eau > 0) THEN   
+        CALL iso_verif_egalite_vect1D( &
+     &           xtrun_off_lic_0,run_off_lic_0,'fonte_neige 100', &
+     &           niso,klon)
+      ENDIF !IF (iso_eau > 0) THEN
+#endif        
+
+!****************************************************************************************
+! Allocate other variables and initilize to zero
+!
+!****************************************************************************************
+
+    ALLOCATE(xtrun_off_ter(niso,klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation xtrun_off_ter'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    xtrun_off_ter(:,:) = 0.
+    
+    ALLOCATE(xtrun_off_lic(niso,klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation xtrun_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    xtrun_off_lic(:,:) = 0.
+
+    ALLOCATE(fxtfonte_global(niso,klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fxtfonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fxtfonte_global(:,:,:) = 0.0
+
+    ALLOCATE(fxtcalving_global(niso,klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fxtcalving_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fxtcalving_global(:,:,:) = 0.0
+
+    ALLOCATE(xtrunofflic_global(niso,klon))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation xtrunofflic_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    xtrunofflic_global(:,:) = 0.0
+
+  END SUBROUTINE fonte_neige_init_iso
+#endif
+
 !
 !****************************************************************************************
@@ -128 +231 @@
   SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, &
        tsurf, precip_rain, precip_snow, &
-       snow, qsol, tsurf_new, evap)
-
-  USE indice_sol_mod
+       snow, qsol, tsurf_new, evap &
+#ifdef ISO    
+     & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag   &
+     & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag   &
+#endif
+     &   )
+
+    USE indice_sol_mod
+#ifdef ISO
+    USE infotrac_phy, ONLY: niso
+    !use isotopes_mod, ONLY: ridicule_snow,iso_eau,iso_HDO
+#ifdef ISOVERIF
+    USE isotopes_verif_mod
+#endif
+#endif
         
 ! Routine de traitement de la fonte de la neige dans le cas du traitement
@@ -172 +287 @@
     REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new
     REAL, DIMENSION(klon), INTENT(INOUT) :: evap
+
+#ifdef ISO    
+        ! sortie de quelques diagnostiques
+    REAL, DIMENSION(klon), INTENT(OUT) :: fq_fonte_diag
+    REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte_diag
+    REAL, DIMENSION(klon), INTENT(OUT) ::  snow_evap_diag 
+    REAL, DIMENSION(klon), INTENT(OUT) ::  fqcalving_diag  
+    REAL,                  INTENT(OUT) :: max_eau_sol_diag  
+    REAL, DIMENSION(klon), INTENT(OUT) ::  runoff_diag   
+    REAL, DIMENSION(klon), INTENT(OUT) :: run_off_lic_diag  
+    REAL,                  INTENT(OUT) :: coeff_rel_diag
+#endif
 
 ! Local variables
@@ -193 +320 @@
 
     LOGICAL               :: neige_fond
+
+#ifdef ISO
+        max_eau_sol_diag=max_eau_sol
+#endif
+
 
 !****************************************************************************************
@@ -231 +363 @@
     
     bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime
+#ifdef ISO
+    snow_evap_diag(:) = snow_evap(:)
+    coeff_rel_diag    = coeff_rel
+#endif
+
 
 
@@ -254 +391 @@
           bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
           tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+#ifdef ISO
+          fq_fonte_diag(i) = fq_fonte
+#endif
+
 
 !IM cf JLD OK     
@@ -273 +414 @@
        snow(i)=MIN(snow(i),snow_max)
     ENDDO
+#ifdef ISO
+    DO i = 1, knon
+       fqcalving_diag(i) = fqcalving(i)
+       fqfonte_diag(i)   = fqfonte(i)
+    ENDDO !DO i = 1, knon
+#endif
+
 
     IF (nisurf == is_ter) THEN
@@ -278 +426 @@
           qsol(i) = qsol(i) + bil_eau_s(i)
           run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+#ifdef ISO
+          runoff_diag(i) = MAX(qsol(i) - max_eau_sol, 0.0)
+#endif
           qsol(i) = MIN(qsol(i), max_eau_sol) 
        ENDDO
@@ -290 +441 @@
        ENDDO
     ENDIF
+
+#ifdef ISO
+    DO i = 1, klon    
+      run_off_lic_diag(i) = run_off_lic(i)
+    ENDDO ! DO i = 1, knon    
+#endif
     
 !****************************************************************************************
@@ -312 +469 @@
 !****************************************************************************************
 !
-  SUBROUTINE fonte_neige_final(restart_runoff)
+  SUBROUTINE fonte_neige_final(restart_runoff &
+#ifdef ISO      
+     &                        ,xtrestart_runoff &
+#endif   
+     &                        )
 !
 ! This subroutine returns run_off_lic_0 for later writing to restart file.
 !
+#ifdef ISO
+    USE infotrac_phy, ONLY: niso
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau
+    USE isotopes_verif_mod
+#endif
+#endif
+!
 !****************************************************************************************
     REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff
+#ifdef ISO     
+    REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrestart_runoff
+#ifdef ISOVERIF
+    INTEGER :: i
+#endif  
+#endif
+
+
 
 !****************************************************************************************
 ! Set the output variables
     restart_runoff(:) = run_off_lic_0(:)
+#ifdef ISO
+    xtrestart_runoff(:,:) = xtrun_off_lic_0(:,:)
+#ifdef ISOVERIF 
+    IF (iso_eau > 0) THEN   
+      DO i=1,klon
+        IF (iso_verif_egalite_nostop(run_off_lic_0(i) &
+     &                              ,xtrun_off_lic_0(iso_eau,i) &
+     &                              ,'fonte_neige 413') &
+     &      == 1) then
+          WRITE(*,*) 'i=',i
+          STOP
+        ENDIF
+      ENDDO !DO i=1,klon
+    ENDIF !IF (iso_eau > 0) then 
+#endif    
+#endif
+
+
 
 ! Deallocation of all varaibles in the module
@@ -334 +529 @@
     IF (ALLOCATED(fqcalving_global)) DEALLOCATE(fqcalving_global)
     IF (ALLOCATED(runofflic_global)) DEALLOCATE(runofflic_global)
+#ifdef ISO
+    IF (ALLOCATED(xtrun_off_lic_0)) DEALLOCATE(xtrun_off_lic_0)
+    IF (ALLOCATED(xtrun_off_ter)) DEALLOCATE(xtrun_off_ter)
+    IF (ALLOCATED(xtrun_off_lic)) DEALLOCATE(xtrun_off_lic)
+    IF (ALLOCATED(fxtfonte_global)) DEALLOCATE(fxtfonte_global)
+    IF (ALLOCATED(fxtcalving_global)) DEALLOCATE(fxtcalving_global)
+    IF (ALLOCATED(xtrunofflic_global)) DEALLOCATE(xtrunofflic_global)
+#endif
+
 
   END SUBROUTINE fonte_neige_final
@@ -340 +544 @@
 !
   SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, &
-       fqfonte_out, ffonte_out, run_off_lic_out)
+              fqfonte_out, ffonte_out, run_off_lic_out &
+#ifdef ISO     
+     &       ,fxtcalving_out, fxtfonte_out,xtrun_off_lic_out &
+#endif     
+     &       )
 
 
@@ -349 +557 @@
 !****************************************************************************************
 
-  USE indice_sol_mod
+    USE indice_sol_mod
+#ifdef ISO
+    USE infotrac_phy, ONLY: niso
+#endif
 
     REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
@@ -358 +569 @@
     REAL, DIMENSION(klon), INTENT(OUT)      :: run_off_lic_out
 
+#ifdef ISO
+    REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxtcalving_out
+    REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxtfonte_out
+    REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrun_off_lic_out
+    INTEGER   :: i,ixt
+#endif
+ 
     INTEGER   :: nisurf
 !****************************************************************************************
@@ -364 +582 @@
     fqfonte_out(:)   = 0.0
     fqcalving_out(:) = 0.0
+#ifdef ISO        
+    fxtfonte_out(:,:)   = 0.0
+    fxtcalving_out(:,:) = 0.0
+#endif
 
     DO nisurf = 1, nbsrf
@@ -373 +595 @@
     run_off_lic_out(:)=runofflic_global(:)
 
+#ifdef ISO
+    DO nisurf = 1, nbsrf
+      DO i=1,klon
+        DO ixt=1,niso
+          fxtfonte_out(ixt,i) = fxtfonte_out(ixt,i) + fxtfonte_global(ixt,i,nisurf)*pctsrf(i,nisurf)
+          fxtcalving_out(ixt,i) = fxtcalving_out(ixt,i) + fxtcalving_global(ixt,i,nisurf)*pctsrf(i,nisurf)
+        ENDDO !DO ixt=1,niso
+      ENDDO !DO i=1,klon
+    ENDDO !DO nisurf = 1, nbsrf
+    xtrun_off_lic_out(:,:) = xtrunofflic_global(:,:)
+#endif
+
   END SUBROUTINE fonte_neige_get_vars
 !
 !****************************************************************************************
 !
+!#ifdef ISO
+!  subroutine fonte_neige_export_xtrun_off_lic_0(knon,xtrun_off_lic_0_diag)
+!    use infotrac_phy, ONLY: niso
+!
+!    ! inputs
+!    INTEGER, INTENT(IN)                      :: knon
+!    real, INTENT(IN), DIMENSION(niso,klon)   :: xtrun_off_lic_0_diag
+!
+!    xtrun_off_lic_0(:,:)=xtrun_off_lic_0_diag(:,:)
+!
+!  end subroutine fonte_neige_export_xtrun_off_lic_0
+!#endif 
+
+#ifdef ISO
+  SUBROUTINE gestion_neige_besoin_varglob_fonte_neige(klon,knon, &
+     &           xtprecip_snow,xtprecip_rain, &
+     &           fxtfonte_neige,fxtcalving, &
+     &           knindex,nisurf,run_off_lic_diag,coeff_rel_diag)
+
+        ! dans cette routine, on a besoin des variables globales de
+        ! fonte_neige_mod. Il faut donc la mettre dans fonte_neige_mod
+        ! le reste de gestion_neige est dans isotopes_routines_mod car sinon pb
+        ! de dépendance circulaire.
+
+    USE infotrac_phy, ONLY: ntiso,niso
+    USE isotopes_mod, ONLY: iso_eau    
+    USE indice_sol_mod    
+#ifdef ISOVERIF
+    USE isotopes_verif_mod
+#endif
+    IMPLICIT NONE
+
+    ! inputs
+    INTEGER, INTENT(IN)                     :: klon,knon
+    REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_snow, xtprecip_rain
+    REAL, DIMENSION(niso,klon), INTENT(IN)  :: fxtfonte_neige,fxtcalving
+    INTEGER, INTENT(IN)                     :: nisurf
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: run_off_lic_diag  
+    REAL, INTENT(IN)                        :: coeff_rel_diag  
+
+    ! locals
+    INTEGER :: i,ixt,j
+        
+#ifdef ISOVERIF
+    IF (nisurf == is_lic) THEN
+      IF (iso_eau > 0) THEN  
+        DO i = 1, knon
+           j = knindex(i)
+           CALL iso_verif_egalite(xtrun_off_lic_0(iso_eau,j), &
+     &             run_off_lic_0(j),'gestion_neige_besoin_varglob_fonte_neige 625')
+        ENDDO
+      ENDIF
+    ENDIF
+#endif
+
+! calcul de run_off_lic 
+
+    IF (nisurf == is_lic) THEN
+!         coeff_rel = dtime/(tau_calv * rday)
+
+      DO i = 1, knon
+        j = knindex(i)
+        DO ixt = 1, niso
+          xtrun_off_lic(ixt,i)   = (coeff_rel_diag *  fxtcalving(ixt,i)) &
+     &                            +(1. - coeff_rel_diag) * xtrun_off_lic_0(ixt,j)
+          xtrun_off_lic_0(ixt,j) = xtrun_off_lic(ixt,i)
+          xtrun_off_lic(ixt,i)   = xtrun_off_lic(ixt,i) + fxtfonte_neige(ixt,i) + xtprecip_rain(ixt,i)
+        ENDDO !DO ixt=1,niso
+#ifdef ISOVERIF
+          IF (iso_eau > 0) THEN             
+            IF (iso_verif_egalite_choix_nostop(xtrun_off_lic(iso_eau,i), &
+     &                  run_off_lic_diag(i),'gestion_neige_besoin_varglob_fonte_neige 1201a', &
+     &                  errmax,errmaxrel) == 1) THEN 
+               WRITE(*,*) 'i,j=',i,j   
+               WRITE(*,*) 'coeff_rel_diag=',coeff_rel_diag
+               STOP
+            ENDIF
+          ENDIF
+#endif
+      ENDDO
+    ENDIF !IF (nisurf == is_lic) THEN  
+
+! Save ffonte, fqfonte and fqcalving in global arrays for each 
+! sub-surface separately
+    DO i = 1, knon
+      DO ixt = 1, niso
+        fxtfonte_global(ixt,knindex(i),nisurf)   = fxtfonte_neige(ixt,i)
+        fxtcalving_global(ixt,knindex(i),nisurf) = fxtcalving(ixt,i)
+      ENDDO !do ixt=1,niso
+    ENDDO   
+
+    IF (nisurf == is_lic) THEN
+      DO i = 1, knon    
+        DO ixt = 1, niso   
+        xtrunofflic_global(ixt,knindex(i)) = xtrun_off_lic(ixt,i)
+        ENDDO ! DO ixt=1,niso   
+      ENDDO
+    ENDIF
+       
+  END SUBROUTINE gestion_neige_besoin_varglob_fonte_neige
+#endif
+
+
 END MODULE fonte_neige_mod

LMDZ6/branches/cirrus/libf/phylmd/infotrac_phy.F90

@@ -5 +5 @@
    USE       strings_mod, ONLY: msg, fmsg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse, strIdx
    USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, setGeneration, itZonIso, nzone, tran0, isoZone, &
-        delPhase, niso, getKey, isot_type, readIsotopesFile, isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, &
-        addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate,   isoCheck, nbIso, ntiso, isoName
+        delPhase, niso, getKey, isot_type, processIsotopes,  isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, &
+        addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate,  iqWIsoPha, nbIso, ntiso, isoName, isoCheck
    IMPLICIT NONE
 
@@ -20 +20 @@
    PUBLIC :: id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat, id_TEST_strat
 #endif
-#ifdef REPROBUS
-   PUBLIC :: nbtr_bin, nbtr_sulgas
-   PUBLIC :: id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat, &
-             id_TEST_strat
-#endif
-
+
+   !=== FOR WATER
+   PUBLIC :: ivap, iliq, isol
    !=== FOR ISOTOPES: General
    PUBLIC :: isot_type, nbIso                              !--- Derived type, full isotopes families database + nb of families
@@ -37 +34 @@
    PUBLIC :: itZonIso                                      !--- idx "it" (in "isoName(1:niso)") = function(tagging idx, isotope idx)
    PUBLIC :: iqIsoPha                                      !--- idx "iq" (in "qx") = function(isotope idx, phase idx) + aliases
+   PUBLIC :: iqWIsoPha                                      !--- Same as iqIsoPha but with normal water phases
+
    PUBLIC :: isoCheck                                      !--- Run isotopes checking routines
    !=== FOR BOTH TRACERS AND ISOTOPES
@@ -73 +72 @@
 !  | longName    | Long name (with adv. scheme suffix) for outputs      | ttext       |                        |
 !  | type        | Type (so far: tracer or tag)                         | /           | tracer,tag             |
-!  | phase       | Phases list ("g"as / "l"iquid / "s"olid / "b"lowing) | /           | [g][l][s][b]           |
+!  | phase       | Phases list ("g"as / "l"iquid / "s"olid)             | /           | [g][l][s]              |
 !  | component   | Name(s) of the merged/cumulated section(s)           | /           | coma-separated names   |
 !  | iGeneration | Generation (>=1)                                     | /           |                        |
@@ -98 +97 @@
 !  | trac   | ntiso  | Isotopes + tagging tracers list + number         | / | ntraciso       |                 |
 !  | zone   | nzone  | Geographic tagging zones   list + number         | / | ntraceurs_zone |                 |
-!  | phase  | nphas  | Phases                     list + number         |                    |[g][l][s][b] 1:4 |
+!  | phase  | nphas  | Phases                     list + number         |                    | [g][l][s], 1:3  |
 !  | iqIsoPha        | Index in "qx"           = f(name(1:ntiso)),phas) | iqiso              | 1:nqtot         |
+!  | iqWIsoPha       | Index in "qx"           = f(name(1:ntiso)),phas) | iqiso              | 1:nqtot         |
 !  | itZonIso        | Index in "trac(1:ntiso)"= f(zone, name(1:niso))  | index_trac         | 1:ntiso         |
 !  +-----------------+--------------------------------------------------+--------------------+-----------------+
@@ -112 +112 @@
 !$OMP THREADPRIVATE(nqtot, nbtr, nqo, nqtottr, nqCO2, type_trac)
 
+   !=== INDICES OF WATER
+   INTEGER,               SAVE :: ivap,iliq,isol ! Indices for vap, liq and ice
+!$OMP THREADPRIVATE(ivap,iliq,isol)
+
    !=== VARIABLES FOR INCA
    INTEGER,               SAVE, ALLOCATABLE :: conv_flg(:), &   !--- Convection     activation ; needed for INCA        (nbtr)
@@ -123 +127 @@
   INTEGER, SAVE ::  id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat, id_TEST_strat
 !$OMP THREADPRIVATE(id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat, id_TEST_strat)
-#endif
-#ifdef REPROBUS
-  INTEGER, SAVE ::  nbtr_bin, nbtr_sulgas
-!$OMP THREADPRIVATE(nbtr_bin, nbtr_sulgas)
-  INTEGER, SAVE ::  id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat,&
-                    id_TEST_strat
-!$OMP THREADPRIVATE(id_OCS_strat, id_SO2_strat, id_H2SO4_strat, id_BIN01_strat)
-!$OMP THREADPRIVATE(id_TEST_strat)
 #endif
 
@@ -182 +178 @@
    INTEGER :: nqtrue                                                 !--- Tracers nb from tracer.def (no higher order moments)
    INTEGER :: iad                                                    !--- Advection scheme number
-   INTEGER :: ic, iq, jq, it, nt, im, nm, iz, k                      !--- Indexes and temporary variables
-   LOGICAL :: lerr, ll, lInit
-   CHARACTER(LEN=1) :: p
+   INTEGER :: iq, jq, nt, im, nm, k                                 !--- Indexes and temporary variables
+   LOGICAL :: lerr, lInit
    TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:)
    TYPE(trac_type), POINTER             :: t1, t(:)
-   INTEGER :: ierr
    CHARACTER(LEN=maxlen),   ALLOCATABLE :: types_trac(:)  !--- Keyword for tracers type(s), parsed version
    
@@ -262 +256 @@
 !##############################################################################################################################
    IF(lInit) THEN
-      IF(readTracersFiles(ttp, type_trac == 'repr')) CALL abort_physic(modname, 'problem with tracers file(s)',1)
+      IF(readTracersFiles(ttp, lRepr=type_trac=='repr')) CALL abort_physic(modname, 'problem with tracers file(s)',1)
    ELSE
       CALL msg('No tracers description file(s) reading needed: already done in the dynamics', modname)
@@ -388 +382 @@
 
    !--- SET FIELDS %iqParent, %nqChildren, %iGeneration, %iqDescen, %nqDescen
-   CALL indexUpdate(tracers)
+   IF(indexUpdate(tracers)) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1)
 
 !##############################################################################################################################
@@ -404 +398 @@
    !=== READ PHYSICAL PARAMETERS FOR ISOTOPES
    niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE.
-   IF(readIsotopesFile()) CALL abort_physic(modname, 'Problem when reading isotopes parameters', 1)
+   IF(processIsotopes()) CALL abort_physic(modname, 'Problem when processing isotopes parameters', 1)
 
 !##############################################################################################################################
@@ -416 +410 @@
    nqtottr = nqtot - COUNT(delPhase(tracers%gen0Name) == 'H2O' .AND. tracers%component == 'lmdz')
    IF(COUNT(tracers%iso_iName == 0) - COUNT(delPhase(tracers%name) == 'H2O' .AND. tracers%component == 'lmdz') /= nqtottr) &
-      CALL abort_physic(modname, 'pb dans le calcul de nqtottr', 1)
+      CALL abort_physic(modname, 'problem with the computation of nqtottr', 1)
 
    !=== DISPLAY THE RESULTS
@@ -431 +425 @@
    t => tracers
    CALL msg('Information stored in infotrac_phy :', modname)
-   IF(dispTable('issssssssiiiiiiii', &
-      ['iq    ', 'name  ', 'lName ', 'gen0N ', 'parent', 'type  ', 'phase ', 'compon', 'isPhy ',           &
-                 'iGen  ', 'iqPar ', 'nqDes ', 'nqChld', 'iGroup', 'iName ', 'iZone ', 'iPhase'],          &
+   IF(dispTable('issssssssiiiiiiii', ['iq  ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp',      &
+                              'isPh', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'],     &
       cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component, bool2str(t%isInPhysics)),&
       cat([(iq, iq=1, nqtot)], t%iGeneration, t%iqParent, t%nqDescen, t%nqChildren, t%iso_iGroup,          &

LMDZ6/branches/cirrus/libf/phylmd/lmdz_atke_exchange_coeff.F90

@@ -7 +7 @@
 subroutine atke_compute_km_kh(ngrid,nlay,dtime, &
                         wind_u,wind_v,temp,qvap,play,pinterf,cdrag_uv, &
-                        tke,eps,Km_out,Kh_out)
+                        tke,eps,tke_shear,tke_buoy,tke_trans,Km_out,Kh_out)
 
 !========================================================================
@@ -79 +79 @@
 
 REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: eps      ! output: TKE dissipation rate at interface between layers (m2/s3)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_shear! output: TKE shear production rate (m2/s3)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_buoy ! output: TKE buoyancy production rate (m2/s3)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_trans! output: TKE transport (diffusion) term (m2/s3)
 REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Km_out   ! output: Exchange coefficient for momentum at interface between layers (m2/s)
 REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Kh_out   ! output: Exchange coefficient for heat flux at interface between layers (m2/s)
@@ -261 +264 @@
                 shear2(igrid,ilay) * (1. - Ri(igrid,ilay) / Prandtl(igrid,ilay))
                 eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+                tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) 
+                tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) &
+                                    *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
             ENDDO
         ENDDO
@@ -278 +284 @@
             qq=max(0.,qq)
             tke(igrid,ilay)=0.5*(qq**2)
-            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay)) 
+            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay)) 
             ENDDO
         ENDDO
@@ -293 +302 @@
             qq=(qq+l_exchange(igrid,ilay)*Sm(igrid,ilay)*dtime/sqrt(2.)      & 
                 *shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay))) &
-                /(1.+qq*dtime/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.))) 
+                /(1.+qq*dtime/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay)) 
             tke(igrid,ilay)=0.5*(qq**2) 
             eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
@@ -308 +320 @@
             eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
             qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
             IF (Ri(igrid,ilay) .LT. 0.) THEN
                 netloss=qq/(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay))
@@ -327 +342 @@
             DO igrid=1,ngrid
             qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
             qq=(l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay)) &
                 +qq*(1.+dtime*qq/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))) &
@@ -349 +367 @@
     tke(igrid,nlay+1)=0.
     eps(igrid,nlay+1)=0.
+    tke_shear(igrid,nlay+1)=0.
+    tke_buoy(igrid,nlay+1)=0.
 END DO
 
@@ -359 +379 @@
     tke(igrid,1)=ctkes*(ustar**2)
     eps(igrid,1)=0. ! arbitrary as TKE is not properly defined at the surface
+    tke_shear(igrid,1)=0.
+    tke_buoy(igrid,1)=0.
 END DO
 
@@ -364 +386 @@
 ! vertical diffusion of TKE 
 !==========================
+tke_trans(:,:)=0.
 IF (atke_ok_vdiff) THEN
-    CALL atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke)
+    CALL atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke,tke_trans)
 ENDIF
 
@@ -387 +410 @@
 
 !===============================================================================================
-subroutine atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke)
+subroutine atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke,tke_trans)
 
 ! routine that computes the vertical diffusion of TKE by the turbulence
@@ -408 +431 @@
 
 REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke    ! turbulent kinetic energy at interface between layers
-
+REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke_trans ! turbulent kinetic energy transport term (m2/s3)
 
 
@@ -480 +503 @@
 ! update TKE
 tke(:,:)=tke(:,:)+dtke(:,:)
+tke_trans(:,:)=dtke(:,:)/dtime
 
 

LMDZ6/branches/cirrus/libf/phylmd/lmdz_atke_turbulence_ini.F90

@@ -50 +50 @@
       !!
       !! ** Purpose :   Initialization of the atke module and choice of some constants
-      !!               
+      !!                Default values correspond to the  'best' configuration
+      !!                from tuning on GABLS1 in Vignon et al. 2024, JAMES
       !!----------------------------------------------------------------------
 
@@ -73 +74 @@
 
       ! flag that controls options in atke_compute_km_kh
-      iflag_atke=0
+      iflag_atke=1
       CALL getin_p('iflag_atke',iflag_atke)
 
       ! flag that controls the calculation of mixing length in atke
-      iflag_atke_lmix=0
+      iflag_atke_lmix=3
       CALL getin_p('iflag_atke_lmix',iflag_atke_lmix)
 
@@ -86 +87 @@
 
       ! activate vertical diffusion of TKE or not
-      atke_ok_vdiff=.false.
+      atke_ok_vdiff=.true.
       CALL getin_p('atke_ok_vdiff',atke_ok_vdiff)
 
@@ -101 +102 @@
       ! Sun et al 2011, JAMC 
       ! between 10 and 40
-      l0=15.0 
+      l0=42.5279652116005 
       CALL getin_p('atke_l0',l0)
 
       ! critical Richardson number 
-      ric=0.25
+      ric=0.190537327781655
       CALL getin_p('atke_ric',ric)
 
       ! constant for tke dissipation calculation
-      cepsilon=5.87 ! default value as in yamada4
+      cepsilon=8.89273387537601
       CALL getin_p('atke_cepsilon',cepsilon)
 
@@ -131 +132 @@
 
       ! slope of Pr=f(Ri) for stable conditions
-      pr_slope=5.0 ! default value from Zilitinkevich et al. 2005
+      pr_slope=4.67885738180385
       CALL getin_p('atke_pr_slope',pr_slope)
       if (pr_slope .le. 1) then
@@ -139 +140 @@
 
       ! value of turbulent prandtl number in neutral conditions (Ri=0)
-      pr_neut=0.8
+      pr_neut=0.837372701768868
       CALL getin_p('atke_pr_neut',pr_neut)
 
@@ -151 +152 @@
 
       ! coefficient for mixing length depending on local stratification
-      clmix=0.5
+      clmix=0.648055235325291
       CALL getin_p('atke_clmix',clmix)
 
@@ -160 +161 @@
       ! minimum anisotropy coefficient (defined here as minsqrt(Ez/Ek)) at large Ri. 
       ! From Zilitinkevich et al. 2013, it equals sqrt(0.03)~0.17  
-      smmin=0.17
+      smmin=0.0960838631869678
       CALL getin_p('atke_smmin',smmin)
 
       ! ratio between the eddy diffusivity coeff for tke wrt that for momentum
       ! default value from Lenderink et al. 2004
-      cke=2.
+      cke=2.47069655134662
       CALL getin_p('atke_cke',cke)
 

LMDZ6/branches/cirrus/libf/phylmd/lmdz_call_atke.F90

@@ -8 +8 @@
 contains
 
-subroutine call_atke(dtime,ngrid,nlay,cdrag_uv,cdrag_t,u_surf,v_surf,temp_surf, &
+subroutine call_atke(dtime,ngrid,nlay,nsrf,ni,cdrag_uv,cdrag_t,u_surf,v_surf,temp_surf, &
                         wind_u,wind_v,temp,qvap,play,pinterf, &
                         tke,eps,Km_out,Kh_out)
@@ -16 +16 @@
 
 USE lmdz_atke_turbulence_ini, ONLY : iflag_num_atke, rg, rd
+USE phys_local_var_mod, ONLY: tke_shear, tke_buoy, tke_trans
 
 implicit none
@@ -26 +27 @@
 INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
 INTEGER, INTENT(IN) :: nlay ! number of vertical index  
+INTEGER, INTENT(IN) :: nsrf ! surface tile index
+INTEGER, DIMENSION(ngrid), INTENT(IN) :: ni ! array of indices to move from knon to klon arrays
 
 
@@ -50 +53 @@
 
 
+REAL, DIMENSION(ngrid,nlay+1) :: tke_shear_term,tke_buoy_term,tke_trans_term
 REAL, DIMENSION(ngrid,nlay) :: wind_u_predict, wind_v_predict
 REAL, DIMENSION(ngrid) ::  wind1
-INTEGER i
+INTEGER i,j,k
 
 
 call atke_compute_km_kh(ngrid,nlay,dtime,&
                         wind_u,wind_v,temp,qvap,play,pinterf,cdrag_uv,&
-                        tke,eps,Km_out,Kh_out)
+                        tke,eps,tke_shear_term,tke_buoy_term,tke_trans_term,Km_out,Kh_out)
 
 
@@ -76 +80 @@
    call atke_compute_km_kh(ngrid,nlay,dtime,&
                         wind_u_predict,wind_v_predict,temp,qvap,play,pinterf,cdrag_uv, &
-                        tke,eps,Km_out,Kh_out)
+                        tke,eps,tke_shear_term,tke_buoy_term,tke_trans_term,Km_out,Kh_out)
 
 end if
 
 
+! Diagnostics of tke loss/source terms
 
+ DO k=1,nlay+1
+    DO i=1,ngrid
+       j=ni(i)
+       tke_shear(j,k,nsrf)=tke_shear_term(i,k)
+       tke_buoy(j,k,nsrf)=tke_buoy_term(i,k)
+       tke_trans(j,k,nsrf)=tke_trans_term(i,k)
+    ENDDO
+ ENDDO
 
 

LMDZ6/branches/cirrus/libf/phylmd/lmdz_lscp.F90

@@ -7 +7 @@
 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 SUBROUTINE lscp(klon,klev,dtime,missing_val,            &
-     paprs,pplay,temp,qt,ptconv,ratqs,                  &
+     paprs,pplay,temp,qt,qice_save,ptconv,ratqs,        &
      d_t, d_q, d_ql, d_qi, rneb, rneblsvol,             &
-     pfraclr,pfracld,                                   &
+     pfraclr, pfracld,                                  &
+     cldfraliq, sigma2_icefracturb,mean_icefracturb,    &
      radocond, radicefrac, rain, snow,                  &
      frac_impa, frac_nucl, beta,                        &
-     prfl, psfl, rhcl, qta, fraca,                     &
-     tv, pspsk, tla, thl, iflag_cld_th,             &
-     iflag_ice_thermo, distcltop, temp_cltop, cell_area,&
-     cf_seri, rvc_seri, u_seri, v_seri, pbl_eps,        &
+     prfl, psfl, rhcl, qta, fraca,                      &
+     tv, pspsk, tla, thl, iflag_cld_th,                 &
+     iflag_ice_thermo, distcltop, temp_cltop,           &
+     tke, tke_dissip,                                   &
+     cell_area,                                         &
+     cf_seri, rvc_seri, u_seri, v_seri,                 &
      qsub, qissr, qcld, subfra, issrfra, gamma_cond,    &
      ratio_qi_qtot, dcf_sub, dcf_con, dcf_mix,          &
@@ -100 +103 @@
 ! USE de modules contenant des fonctions.
 USE lmdz_cloudth, ONLY : cloudth, cloudth_v3, cloudth_v6, cloudth_mpc 
-USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf, icefrac_lscp, calc_gammasat
+USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf, calc_gammasat
+USE lmdz_lscp_tools, ONLY : icefrac_lscp, icefrac_lscp_turb
 USE lmdz_lscp_tools, ONLY : fallice_velocity, distance_to_cloud_top
 USE lmdz_lscp_condensation, ONLY : condensation_lognormal, condensation_ice_supersat
@@ -115 +119 @@
 USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG
 USE lmdz_lscp_ini, ONLY : ok_poprecip
-USE lmdz_lscp_ini, ONLY : ok_external_lognormal, ok_ice_supersat, ok_unadjusted_clouds
+USE lmdz_lscp_ini, ONLY : ok_external_lognormal, ok_ice_supersat, ok_unadjusted_clouds, iflag_icefrac
 
 IMPLICIT NONE
@@ -134 +138 @@
   REAL, DIMENSION(klon,klev),      INTENT(IN)   :: temp            ! temperature (K)
   REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qt              ! total specific humidity (in vapor phase in input) [kg/kg] 
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qice_save       ! ice specific from previous time step [kg/kg]
   INTEGER,                         INTENT(IN)   :: iflag_cld_th    ! flag that determines the distribution of convective clouds
   INTEGER,                         INTENT(IN)   :: iflag_ice_thermo! flag to activate the ice thermodynamics
@@ -141 +146 @@
   !Inputs associated with thermal plumes
 
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tv             ! virtual potential temperature [K]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qta            ! specific humidity within thermals [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: fraca          ! fraction of thermals within the mesh [-]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pspsk          ! exner potential (p/100000)**(R/cp) 
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tla            ! liquid temperature within thermals [K]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tv                  ! virtual potential temperature [K]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qta                 ! specific humidity within thermals [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: fraca               ! fraction of thermals within the mesh [-]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pspsk               ! exner potential (p/100000)**(R/cp) 
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tla                 ! liquid temperature within thermals [K]
+  REAL, DIMENSION(klon,klev+1),      INTENT(IN)   :: tke                 !--turbulent kinetic energy [m2/s2]
+  REAL, DIMENSION(klon,klev+1),      INTENT(IN)   :: tke_dissip          !--TKE dissipation [m2/s3]
 
   ! INPUT/OUTPUT variables
   !------------------------
   
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: thl          ! liquid potential temperature [K]
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: ratqs        ! function of pressure that sets the large-scale
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: thl              ! liquid potential temperature [K]
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: ratqs            ! function of pressure that sets the large-scale
 
   ! INPUT/OUTPUT condensation and ice supersaturation
@@ -160 +167 @@
   REAL, DIMENSION(klon,klev),      INTENT(IN)   :: u_seri           ! eastward wind [m/s]
   REAL, DIMENSION(klon,klev),      INTENT(IN)   :: v_seri           ! northward wind [m/s]
-  REAL, DIMENSION(klon,klev+1),    INTENT(IN)   :: pbl_eps          ! TKE dissipation [?]
   REAL, DIMENSION(klon),           INTENT(IN)   :: cell_area        ! area of each cell [m2]
 
@@ -179 +185 @@
   REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: pfraclr          ! precip fraction clear-sky part [-]
   REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: pfracld          ! precip fraction cloudy part [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cldfraliq           ! liquid fraction of cloud [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: sigma2_icefracturb  ! Variance of the diagnostic supersaturation distribution (icefrac_turb) [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: mean_icefracturb    ! Mean of the diagnostic supersaturation distribution (icefrac_turb) [-]
   REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radocond         ! condensed water used in the radiation scheme [kg/kg]
   REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radicefrac       ! ice fraction of condensed water for radiation scheme
@@ -190 +199 @@
   REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: beta             ! conversion rate of condensed water
 
-  ! fraction of aerosol scavenging through impaction and nucleation (for on-line)
+  ! fraction of aerosol scavenging through impaction and nucleation    (for on-line)
   
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_impa        ! scavenging fraction due tu impaction [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_nucl        ! scavenging fraction due tu nucleation [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_impa           ! scavenging fraction due tu impaction [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_nucl           ! scavenging fraction due tu nucleation [-]
   
   ! for condensation and ice supersaturation
@@ -255 +264 @@
   ! LOCAL VARIABLES:
   !----------------
-
-  REAL,DIMENSION(klon) :: qsl, qsi
+  REAL,DIMENSION(klon) :: qsl, qsi                                ! saturation threshold at current vertical level
   REAL :: zct, zcl,zexpo
   REAL, DIMENSION(klon,klev) :: ctot
@@ -263 +271 @@
   REAL :: zdelta, zcor, zcvm5
   REAL, DIMENSION(klon) :: zdqsdT_raw
-  REAL, DIMENSION(klon) :: gammasat,dgammasatdt                ! coefficient to make cold condensation at the correct RH and derivative wrt T
-  REAL, DIMENSION(klon) :: Tbef,qlbef,DT
+  REAL, DIMENSION(klon) :: gammasat,dgammasatdt                   ! coefficient to make cold condensation at the correct RH and derivative wrt T
+  REAL, DIMENSION(klon) :: Tbef,qlbef,DT                          ! temperature, humidity and temp. variation during lognormal iteration
   REAL :: num,denom
   REAL :: cste
-  REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta
-  REAL, DIMENSION(klon) :: Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2
+  REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta             ! lognormal parameters
+  REAL, DIMENSION(klon) :: Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2          ! lognormal intermediate variables
   REAL :: erf
   REAL, DIMENSION(klon) :: zfice_th
@@ -285 +293 @@
   REAL :: zmelt,zrain,zsnow,zprecip
   REAL, DIMENSION(klon) :: dzfice
+  REAL, DIMENSION(klon) :: zfice_turb, dzfice_turb
   REAL :: zsolid
   REAL, DIMENSION(klon) :: qtot, qzero
@@ -315 +324 @@
   REAL, DIMENSION(klon,klev) :: radocondi, radocondl
   REAL :: effective_zneb
-  REAL, DIMENSION(klon) :: distcltop1D, temp_cltop1D
+  REAL, DIMENSION(klon) :: zdistcltop, ztemp_cltop
+  REAL, DIMENSION(klon) :: zqliq, zqice, zqvapcl        ! for icefrac_lscp_turb
   
   ! for condensation and ice supersaturation
@@ -328 +338 @@
   REAL :: min_qParent, min_ratio
 
-
   INTEGER i, k, n, kk, iter
   INTEGER, DIMENSION(klon) :: n_i
@@ -382 +391 @@
 pfraclr(:,:)=0.0
 pfracld(:,:)=0.0
+cldfraliq(:,:)=0.
+sigma2_icefracturb(:,:)=0.
+mean_icefracturb(:,:)=0.
 radocond(:,:) = 0.0
 radicefrac(:,:) = 0.0
@@ -391 +403 @@
 zfice(:)=0.0
 dzfice(:)=0.0
+zfice_turb(:)=0.0
+dzfice_turb(:)=0.0
 zqprecl(:)=0.0
 zqpreci(:)=0.0
@@ -405 +419 @@
 d_tot_zneb(:) = 0.0
 qzero(:) = 0.0
-distcltop1D(:)=0.0
-temp_cltop1D(:) = 0.0
+zdistcltop(:)=0.0
+ztemp_cltop(:) = 0.0
 ztupnew(:)=0.0
 
@@ -459 +473 @@
 
 
-
 !c_iso: variable initialisation for iso 
 
@@ -478 +491 @@
 
     ! Initialisation temperature and specific humidity
+    ! temp(klon,klev) is not modified by the routine, instead all changes in temperature are made on zt
+    ! at the end of the klon loop, a temperature incremtent d_t due to all processes
+    ! (thermalization, evap/sub incoming precip, cloud formation, precipitation processes) is calculated 
+    ! d_t = temperature tendency due to lscp
+    ! The temperature of the overlying layer is updated here because needed for thermalization
     DO i = 1, klon
         zt(i)=temp(i,k)
@@ -812 +830 @@
                 ELSEIF (iflag_cloudth_vert .EQ. 7) THEN
                    ! Updated version of Arnaud Jam (correction by E. Vignon) + adapted treatment
-                   ! for boundary-layer mixed phase clouds following Vignon et al.  
+                   ! for boundary-layer mixed phase clouds 
                     CALL cloudth_mpc(klon,klev,k,mpc_bl_points,zt,zq,qta(:,k),fraca(:,k), &
                                      pspsk(:,k),paprs(:,k+1),paprs(:,k),pplay(:,k), tla(:,k), &
@@ -834 +852 @@
             
                 ! lognormal 
-            lognormale = .TRUE.
+            lognormale(:) = .TRUE.
 
         ELSEIF (iflag_cld_th .GE. 6) THEN
             
                 ! lognormal distribution when no thermals 
-            lognormale = fraca(:,k) < min_frac_th_cld
+            lognormale(:) = fraca(:,k) < min_frac_th_cld
 
         ELSE
                 ! When iflag_cld_th=5, we always assume
                 ! bi-gaussian distribution
-            lognormale = .FALSE.
+            lognormale(:) = .FALSE.
         
         ENDIF
@@ -900 +918 @@
                   IF (iflag_t_glace.GE.4) THEN
                   ! For iflag_t_glace GE 4 the phase partition function dependends on temperature AND distance to cloud top
-                       CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,distcltop1D,temp_cltop1D)
+                       CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,zdistcltop,ztemp_cltop)
                   ENDIF
-                  CALL icefrac_lscp(klon, zt(:), iflag_ice_thermo, distcltop1D(:),temp_cltop1D(:),zfice(:),dzfice(:))
-
+
+                  CALL icefrac_lscp(klon, zt(:), iflag_ice_thermo, zdistcltop(:),ztemp_cltop(:),zfice(:),dzfice(:))
 
                   !--AB Activates a condensation scheme that allows for
@@ -938 +956 @@
                         pplay(:,k), paprs(:,k), paprs(:,k+1), &
                         cf_seri(:,k), rvc_seri(:,k), ratio_qi_qtot(:,k), &
-                        shear(:), pbl_eps(:,k), cell_area(:), &
+                        shear(:), tke_dissip(:,k), cell_area(:), &
                         Tbef(:), zq(:), zqs(:), gammasat(:), ratqs(:,k), keepgoing(:), &
                         rneb(:,k), zqn(:), qvc(:), issrfra(:,k), qissr(:,k), &
@@ -1017 +1035 @@
                             cste=RLSTT
                         ENDIF
-
+                        
+                        ! LEA_R : check formule
                         IF ( ok_unadjusted_clouds ) THEN
                           !--AB We relax the saturation adjustment assumption
@@ -1059 +1078 @@
         ! For iflag_t_glace GE 4 the phase partition function dependends on temperature AND distance to cloud top
         IF (iflag_t_glace.GE.4) THEN
-            CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,distcltop1D,temp_cltop1D)
-            distcltop(:,k)=distcltop1D(:)
-            temp_cltop(:,k)=temp_cltop1D(:)
-        ENDIF   
-        ! Partition function in stratiform clouds (will be overwritten in boundary-layer MPCs)
-        CALL icefrac_lscp(klon,zt,iflag_ice_thermo,distcltop1D,temp_cltop1D,zfice,dzfice)
-
+           CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,zdistcltop,ztemp_cltop)
+           distcltop(:,k)=zdistcltop(:)
+           temp_cltop(:,k)=ztemp_cltop(:)
+        ENDIF
+
+        ! Partition function depending on temperature
+        CALL icefrac_lscp(klon, zt, iflag_ice_thermo, zdistcltop, ztemp_cltop, zfice, dzfice)
+
+        ! Partition function depending on tke for non shallow-convective clouds 
+        IF (iflag_icefrac .GE. 1) THEN
+
+           CALL icefrac_lscp_turb(klon, dtime, Tbef, pplay(:,k), paprs(:,k), paprs(:,k+1), qice_save(:,k), ziflcld, zqn, &
+           rneb(:,k), tke(:,k), tke_dissip(:,k), zqliq, zqvapcl, zqice, zfice_turb, dzfice_turb, cldfraliq(:,k),sigma2_icefracturb(:,k), mean_icefracturb(:,k))
+
+        ENDIF
 
         ! Water vapor update, Phase determination and subsequent latent heat exchange
         DO i=1, klon
-
+            ! Overwrite phase partitioning in boundary layer mixed phase clouds when the 
+            ! iflag_cloudth_vert=7 and specific param is activated
             IF (mpc_bl_points(i,k) .GT. 0) THEN
-               
                 zcond(i) = MAX(0.0,qincloud_mpc(i))*rneb(i,k)
                 ! following line is very strange and probably wrong
@@ -1078 +1105 @@
                 zq(i) = zq(i) - zcond(i)        
                 zfice(i)=zfice_th(i)
-
             ELSE
-
                 ! Checks on rneb, rhcl and zqn
                 IF (rneb(i,k) .LE. 0.0) THEN
@@ -1108 +1133 @@
                     ! following line is very strange and probably wrong:
                     rhcl(i,k)=(zqs(i)+zq(i))/2./zqs(i)
+                    ! Overwrite partitioning for non shallow-convective clouds if iflag_icefrac>1 (icefrac turb param) 
+                    IF (iflag_icefrac .GE. 1) THEN
+                        IF (lognormale(i)) THEN  
+                           zcond(i)  = zqliq(i) + zqice(i)
+                           zfice(i)=zfice_turb(i)
+                           rhcl(i,k) = zqvapcl(i) * rneb(i,k) + (zq(i) - zqn(i)) * (1.-rneb(i,k))
+                        ENDIF
+                    ENDIF
                 ENDIF
 
@@ -1493 +1526 @@
                 znebprecipcld(i)=0.0
             ENDIF
-
+        !IF ( ((1-zfice(i))*zoliq(i) .GT. 0.) .AND. (zt(i) .LE. 233.15) ) THEN
+        !print*,'WARNING LEA OLIQ A <-40°C '
+        !print*,'zt,Tbef,oliq,oice,cldfraliq,icefrac,rneb',zt(i),Tbef(i),(1-zfice(i))*zoliq(i),zfice(i)*zoliq(i),cldfraliq(i,k),zfice(i),rneb(i,k)
+        !ENDIF 
         ENDDO
 

LMDZ6/branches/cirrus/libf/phylmd/lmdz_lscp_ini.F90

@@ -67 +67 @@
   !$OMP THREADPRIVATE(iflag_t_glace)
 
-  INTEGER, SAVE, PROTECTED :: iflag_cloudth_vert=0         ! option for determining cloud fraction and content in convective boundary layers
+  INTEGER, SAVE, PROTECTED :: iflag_cloudth_vert=0          ! option for determining cloud fraction and content in convective boundary layers
   !$OMP THREADPRIVATE(iflag_cloudth_vert)
 
-  INTEGER, SAVE, PROTECTED :: iflag_gammasat=0             ! which threshold for homogeneous nucleation below -40oC
+  INTEGER, SAVE, PROTECTED :: iflag_gammasat=0              ! which threshold for homogeneous nucleation below -40oC
   !$OMP THREADPRIVATE(iflag_gammasat)
 
-  INTEGER, SAVE, PROTECTED :: iflag_rain_incloud_vol=0     ! use of volume cloud fraction for rain autoconversion 
+  INTEGER, SAVE, PROTECTED :: iflag_rain_incloud_vol=0      ! use of volume cloud fraction for rain autoconversion 
   !$OMP THREADPRIVATE(iflag_rain_incloud_vol)
 
-  INTEGER, SAVE, PROTECTED :: iflag_bergeron=0             ! bergeron effect for liquid precipitation treatment  
+  INTEGER, SAVE, PROTECTED :: iflag_bergeron=0              ! bergeron effect for liquid precipitation treatment  
   !$OMP THREADPRIVATE(iflag_bergeron)
 
-  INTEGER, SAVE, PROTECTED :: iflag_fisrtilp_qsat=0        ! qsat adjustment (iterative) during autoconversion
+  INTEGER, SAVE, PROTECTED :: iflag_fisrtilp_qsat=0         ! qsat adjustment (iterative) during autoconversion
   !$OMP THREADPRIVATE(iflag_fisrtilp_qsat)
 
-  INTEGER, SAVE, PROTECTED :: iflag_pdf=0                  ! type of subgrid scale qtot pdf
+  INTEGER, SAVE, PROTECTED :: iflag_pdf=0                   ! type of subgrid scale qtot pdf
   !$OMP THREADPRIVATE(iflag_pdf)
 
-  INTEGER, SAVE, PROTECTED :: iflag_autoconversion=0       ! autoconversion option
+  INTEGER, SAVE, PROTECTED :: iflag_icefrac=0               ! which phase partitioning function to use
+  !$OMP THREADPRIVATE(iflag_icefrac)
+
+  INTEGER, SAVE, PROTECTED :: iflag_autoconversion=0        ! autoconversion option
   !$OMP THREADPRIVATE(iflag_autoconversion)
 
-  LOGICAL, SAVE, PROTECTED :: reevap_ice=.false.           ! no liquid precip for T< threshold
+
+  LOGICAL, SAVE, PROTECTED :: reevap_ice=.false.            ! no liquid precip for T< threshold
   !$OMP THREADPRIVATE(reevap_ice)
 
-  REAL, SAVE, PROTECTED :: cld_lc_lsc=2.6e-4               ! liquid autoconversion coefficient, stratiform rain
+  REAL, SAVE, PROTECTED :: cld_lc_lsc=2.6e-4                ! liquid autoconversion coefficient, stratiform rain
   !$OMP THREADPRIVATE(cld_lc_lsc)
 
@@ -118 +122 @@
   !$OMP THREADPRIVATE(coef_eva)
 
-  REAL, SAVE, PROTECTED :: coef_sub                        ! tuning coefficient ice precip sublimation
+  REAL, SAVE, PROTECTED :: coef_sub                         ! tuning coefficient ice precip sublimation
   !$OMP THREADPRIVATE(coef_sub)
 
@@ -124 +128 @@
   !$OMP THREADPRIVATE(expo_eva)
 
-  REAL, SAVE, PROTECTED :: expo_sub                       ! tuning coefficient ice precip sublimation
+  REAL, SAVE, PROTECTED :: expo_sub                         ! tuning coefficient ice precip sublimation
   !$OMP THREADPRIVATE(expo_sub)
 
@@ -226 +230 @@
   !$OMP THREADPRIVATE(thresh_precip_frac)
 
+  REAL, SAVE, PROTECTED :: tau_mixenv=100000                ! Homogeneization time of mixed phase clouds [s]
+  !$OMP THREADPRIVATE(tau_mixenv)
+
+    REAL, SAVE, PROTECTED :: capa_crystal=1.                ! Sursaturation of ice part in mixed phase clouds [-]
+  !$OMP THREADPRIVATE(capa_crystal)
+
+  REAL, SAVE, PROTECTED :: lmix_mpc=1000                    ! Length of turbulent zones in Mixed Phase Clouds [m]
+  !$OMP THREADPRIVATE(lmix_mpc)
+
+  REAL, SAVE, PROTECTED :: naero5=0.5                       ! Number concentration of aerosol larger than 0.5 microns [scm-3]
+  !$OMP THREADPRIVATE(naero5)
+
+  REAL, SAVE, PROTECTED :: gamma_snwretro = 0.              ! Proportion of snow taken into account in ice retroaction in icefrac_turb [-]
+  !$OMP THREADPRIVATE(gamma_snwretro)
+
+  REAL, SAVE, PROTECTED :: gamma_taud = 1.                  ! Tuning coeff for tau_dissipturb [-]
+  !$OMP THREADPRIVATE(gamma_taud)
+
   REAL, SAVE, PROTECTED :: gamma_col=1.                     ! A COMMENTER TODO [-]
   !$OMP THREADPRIVATE(gamma_col)
@@ -235 +257 @@
   !$OMP THREADPRIVATE(gamma_rim)
 
-  REAL, SAVE, PROTECTED :: rho_rain=1000.                    ! A COMMENTER TODO [kg/m3]
+  REAL, SAVE, PROTECTED :: rho_rain=1000.                   ! Rain density [kg/m3]
   !$OMP THREADPRIVATE(rho_rain)
 
-  REAL, SAVE, PROTECTED :: rho_ice=920.                    ! A COMMENTER TODO [kg/m3]
+  REAL, SAVE, PROTECTED :: rho_ice=920.                     ! Ice density  [kg/m3]
   !$OMP THREADPRIVATE(rho_ice)
 
-  REAL, SAVE, PROTECTED :: r_rain=500.E-6                   ! A COMMENTER TODO [m]
+  REAL, SAVE, PROTECTED :: r_rain=500.E-6                   ! Rain droplets radius for POPRECIP [m]
   !$OMP THREADPRIVATE(r_rain)
 
-  REAL, SAVE, PROTECTED :: r_snow=1.E-3                    ! A COMMENTER TODO [m]
+  REAL, SAVE, PROTECTED :: r_snow=1.E-3                     ! Ice crystals radius for POPRECIP [m]
   !$OMP THREADPRIVATE(r_snow)
 
-  REAL, SAVE, PROTECTED :: tau_auto_snow_min=100.          ! A COMMENTER TODO [s]
+  REAL, SAVE, PROTECTED :: tau_auto_snow_min=100.           ! A COMMENTER TODO [s]
   !$OMP THREADPRIVATE(tau_auto_snow_min)
 
@@ -256 +278 @@
   !$OMP THREADPRIVATE(eps)
 
-  REAL, SAVE, PROTECTED :: gamma_melt=1.                   ! A COMMENTER TODO [-]
+  REAL, SAVE, PROTECTED :: gamma_melt=1.                    ! A COMMENTER TODO [-]
   !$OMP THREADPRIVATE(gamma_melt)
 
-  REAL, SAVE, PROTECTED :: alpha_freez=4.                 ! A COMMENTER TODO [-]
+  REAL, SAVE, PROTECTED :: alpha_freez=4.                   ! A COMMENTER TODO [-]
   !$OMP THREADPRIVATE(alpha_freez)
 
-  REAL, SAVE, PROTECTED :: beta_freez=0.1                 ! A COMMENTER TODO [m-3.s-1]
+  REAL, SAVE, PROTECTED :: beta_freez=0.1                   ! A COMMENTER TODO [m-3.s-1]
   !$OMP THREADPRIVATE(beta_freez)
 
-  REAL, SAVE, PROTECTED :: gamma_freez=1.                 ! A COMMENTER TODO [-]
+  REAL, SAVE, PROTECTED :: gamma_freez=1.                   ! A COMMENTER TODO [-]
   !$OMP THREADPRIVATE(gamma_freez)
 
-  REAL, SAVE, PROTECTED :: rain_fallspeed=4.              ! A COMMENTER TODO [m/s]
+  REAL, SAVE, PROTECTED :: rain_fallspeed=4.                ! A COMMENTER TODO [m/s]
   !$OMP THREADPRIVATE(rain_fallspeed)
 
-  REAL, SAVE, PROTECTED :: rain_fallspeed_clr              ! A COMMENTER TODO [m/s]
+  REAL, SAVE, PROTECTED :: rain_fallspeed_clr                ! A COMMENTER TODO [m/s]
   !$OMP THREADPRIVATE(rain_fallspeed_clr)
 
-  REAL, SAVE, PROTECTED :: rain_fallspeed_cld             ! A COMMENTER TODO [m/s]
+  REAL, SAVE, PROTECTED :: rain_fallspeed_cld               ! A COMMENTER TODO [m/s]
   !$OMP THREADPRIVATE(rain_fallspeed_cld)
 
-  REAL, SAVE, PROTECTED :: snow_fallspeed=1.             ! A COMMENTER TODO [m/s]
+  REAL, SAVE, PROTECTED :: snow_fallspeed=1.               ! A COMMENTER TODO [m/s]
   !$OMP THREADPRIVATE(snow_fallspeed)
 
-  REAL, SAVE, PROTECTED :: snow_fallspeed_clr             ! A COMMENTER TODO [m/s]
+  REAL, SAVE, PROTECTED :: snow_fallspeed_clr               ! A COMMENTER TODO [m/s]
   !$OMP THREADPRIVATE(snow_fallspeed_clr)
 
-  REAL, SAVE, PROTECTED :: snow_fallspeed_cld             ! A COMMENTER TODO [m/s]
+  REAL, SAVE, PROTECTED :: snow_fallspeed_cld               ! A COMMENTER TODO [m/s]
   !$OMP THREADPRIVATE(snow_fallspeed_cld)
   !--End of the parameters for poprecip
@@ -325 +347 @@
     RLMLT=RLMLT_in
     RTT=RTT_in
-    RG=RG_in
+    RV=RV_in
     RVTMP2=RVTMP2_in
     RPI=RPI_in
@@ -347 +369 @@
     CALL getin_p('iflag_fisrtilp_qsat',iflag_fisrtilp_qsat)
     CALL getin_p('iflag_pdf',iflag_pdf)
+    CALL getin_p('iflag_icefrac',iflag_icefrac)
     CALL getin_p('reevap_ice',reevap_ice)
     CALL getin_p('cld_lc_lsc',cld_lc_lsc)
@@ -368 +391 @@
     CALL getin_p('dist_liq',dist_liq)
     CALL getin_p('tresh_cl',tresh_cl)
+    CALL getin_p('tau_mixenv',tau_mixenv)
+    CALL getin_p('capa_crystal',capa_crystal)
+    CALL getin_p('lmix_mpc',lmix_mpc)
+    CALL getin_p('naero5',naero5)
+    CALL getin_p('gamma_snwretro',gamma_snwretro)
+    CALL getin_p('gamma_taud',gamma_taud)
     CALL getin_p('iflag_oldbug_fisrtilp',iflag_oldbug_fisrtilp)
     CALL getin_p('temp_nowater',temp_nowater)
@@ -430 +459 @@
     WRITE(lunout,*) 'lscp_ini, iflag_fisrtilp_qsat:', iflag_fisrtilp_qsat
     WRITE(lunout,*) 'lscp_ini, iflag_pdf', iflag_pdf
+    WRITE(lunout,*) 'lscp_ini, iflag_icefrac', iflag_icefrac
     WRITE(lunout,*) 'lscp_ini, reevap_ice', reevap_ice
     WRITE(lunout,*) 'lscp_ini, cld_lc_lsc', cld_lc_lsc
@@ -448 +478 @@
     WRITE(lunout,*) 'lscp_ini, dist_liq', dist_liq
     WRITE(lunout,*) 'lscp_ini, tresh_cl', tresh_cl
+    WRITE(lunout,*) 'lscp_ini, tau_mixenv', tau_mixenv
+    WRITE(lunout,*) 'lscp_ini, capa_crystal', capa_crystal
+    WRITE(lunout,*) 'lscp_ini, lmix_mpc', lmix_mpc
+    WRITE(lunout,*) 'lscp_ini, naero5', naero5
+    WRITE(lunout,*) 'lscp_ini, gamma_snwretro', gamma_snwretro
+    WRITE(lunout,*) 'lscp_ini, gamma_taud', gamma_taud
     WRITE(lunout,*) 'lscp_ini, iflag_oldbug_fisrtilp', iflag_oldbug_fisrtilp
     WRITE(lunout,*) 'lscp_ini, fl_cor_ebil', fl_cor_ebil

LMDZ6/branches/cirrus/libf/phylmd/lmdz_lscp_poprecip.F90

@@ -559 +559 @@
 
     !--Same as for aggregation
-    !--Eff_snow_liq formula: following Milbrandt and Yau 2005,
+    !--Eff_snow_liq formula:
     !--it s a product of a collection efficiency and a sticking efficiency
-    Eff_snow_ice = 0.05 * EXP( 0.1 * ( temp(i) - RTT ) )
+    ! Milbrandt and Yau formula that gives very low values:
+    ! Eff_snow_ice = 0.05 * EXP( 0.1 * ( temp(i) - RTT ) )
+    ! Lin 1983's formula 
+    Eff_snow_ice = EXP( 0.025 * MIN( ( temp(i) - RTT ), 0.) ) 
     !--rho_snow formula follows Brandes et al. 2007 (JAMC)
     rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
@@ -653 +656 @@
     !--NB.: this process needs a temperature adjustment
 
-    !--Eff_snow_liq formula: following Seifert and Beheng 2006,
-    !--assuming a cloud droplet diameter of 20 microns.
-    Eff_snow_liq = 0.2
+    !--Eff_snow_liq formula: following Ferrier 1994,
+    !--assuming 1
+    Eff_snow_liq = 1.0
     !--rho_snow formula follows Brandes et al. 2007 (JAMC)
     rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)

LMDZ6/branches/cirrus/libf/phylmd/lmdz_lscp_tools.F90

@@ -136 +136 @@
     CHARACTER (len = 80) :: abort_message
 
-    IF ((iflag_t_glace.LT.2) .OR. (iflag_t_glace.GT.6)) THEN
+    IF ((iflag_t_glace.LT.2)) THEN !.OR. (iflag_t_glace.GT.6)) THEN
        abort_message = 'lscp cannot be used if iflag_t_glace<2 or >6'
        CALL abort_physic(modname,abort_message,1)
@@ -194 +194 @@
 
         ! with CMIP6 function of temperature at cloud top
-        IF (iflag_t_glace .EQ. 5) THEN 
+        IF ((iflag_t_glace .EQ. 5) .OR. (iflag_t_glace .EQ. 7)) THEN 
                 liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
                 liqfrac_tmp =  MIN(MAX(liqfrac_tmp,0.0),1.0)
@@ -232 +232 @@
                 ENDIF 
         ENDIF
-
+      
 
      ENDDO ! klon
- 
      RETURN
  
@@ -241 +240 @@
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
+SUBROUTINE ICEFRAC_LSCP_TURB(klon, dtime, temp, pplay, paprsdn, paprsup, qice_ini, snowcld, qtot_incl, cldfra, tke, tke_dissip, qliq, qvap_cld, qice, icefrac, dicefracdT, cldfraliq, sigma2_icefracturb, mean_icefracturb)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! Compute the liquid, ice and vapour content (+ice fraction) based 
+  ! on turbulence (see Fields 2014, Furtado 2016, Raillard 2025)
+  ! L.Raillard (30/08/24)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+   USE lmdz_lscp_ini, ONLY : prt_level, lunout
+   USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RV, RPI
+   USE lmdz_lscp_ini, ONLY : seuil_neb, temp_nowater
+   USE lmdz_lscp_ini, ONLY : tau_mixenv, lmix_mpc, naero5, gamma_snwretro, gamma_taud, capa_crystal
+   USE lmdz_lscp_ini, ONLY : eps
+
+   IMPLICIT NONE
+
+   INTEGER,   INTENT(IN)                           :: klon              !--number of horizontal grid points
+   REAL,      INTENT(IN)                           :: dtime             !--time step [s]
+
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: temp              !--temperature
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: pplay             !--pressure in the middle of the layer       [Pa]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: paprsdn           !--pressure at the bottom interface of the layer [Pa]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: paprsup           !--pressure at the top interface of the layer [Pa]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: qtot_incl         !--specific total cloud water content, in-cloud content [kg/kg]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: cldfra            !--cloud fraction in gridbox [-]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: tke               !--turbulent kinetic energy [m2/s2]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: tke_dissip        !--TKE dissipation [m2/s3]
+
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: qice_ini          !--initial specific ice content gridbox-mean [kg/kg]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: snowcld
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qliq              !--specific liquid content gridbox-mean [kg/kg]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qvap_cld          !--specific cloud vapor content, gridbox-mean [kg/kg]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qice              !--specific ice content gridbox-mean [kg/kg]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: icefrac           !--fraction of ice in condensed water [-]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: dicefracdT
+
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: cldfraliq         !--fraction of cldfra which is liquid only
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: sigma2_icefracturb     !--Temporary 
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: mean_icefracturb      !--Temporary 
+
+   REAL, DIMENSION(klon) :: qzero, qsatl, dqsatl, qsati, dqsati         !--specific humidity saturation values
+   INTEGER :: i
+
+   REAL :: qvap_incl, qice_incl, qliq_incl, qiceini_incl                !--In-cloud specific quantities [kg/kg]
+   REAL :: qsnowcld_incl
+   !REAL :: capa_crystal                                                 !--Capacitance of ice crystals  [-]
+   REAL :: water_vapor_diff                                             !--Water-vapour diffusion coefficient in air [m2/s] (function of T&P)
+   REAL :: air_thermal_conduct                                          !--Thermal conductivity of air [J/m/K/s] (function of T)
+   REAL :: C0                                                           !--Lagrangian structure function [-]
+   REAL :: tau_mixingenv
+   REAL :: tau_dissipturb
+   REAL :: invtau_phaserelax
+   REAL :: sigma2_pdf, mean_pdf
+   REAL :: ai, bi, B0
+   REAL :: sursat_iceliq
+   REAL :: sursat_env
+   REAL :: liqfra_max
+   REAL :: sursat_iceext
+   REAL :: nb_crystals                                                  !--number concentration of ice crystals [#/m3]
+   REAL :: moment1_PSD                                                  !--1st moment of ice PSD 
+   REAL :: N0_PSD, lambda_PSD                                           !--parameters of the exponential PSD
+
+   REAL :: rho_ice                                                      !--ice density [kg/m3]
+   REAL :: cldfra1D
+   REAL :: deltaz, rho_air
+   REAL :: psati                                                        !--saturation vapor pressure wrt i [Pa]
+   
+   C0            = 10.                                                  !--value assumed in Field2014            
+   rho_ice       = 950.
+   sursat_iceext = -0.1
+   !capa_crystal  = 1. !r_ice                                       
+   qzero(:)      = 0.
+   cldfraliq(:)  = 0.
+   icefrac(:)    = 0.
+   dicefracdT(:) = 0.
+
+   sigma2_icefracturb(:) = 0.
+   mean_icefracturb(:)  = 0.
+
+   !--wrt liquid water
+   CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,1,.false.,qsatl(:),dqsatl(:))
+   !--wrt ice
+   CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,2,.false.,qsati(:),dqsati(:))
+
+
+    DO i=1,klon
+
+
+     rho_air  = pplay(i) / temp(i) / RD
+     !deltaz   = ( paprsdn(i) - paprsup(i) ) / RG / rho_air(i)
+     ! because cldfra is intent in, but can be locally modified due to test 
+     cldfra1D = cldfra(i)
+     IF (cldfra(i) .LE. 0.) THEN
+        qvap_cld(i)   = 0.
+        qliq(i)       = 0.
+        qice(i)       = 0.
+        cldfraliq(i)  = 0.
+        icefrac(i)    = 0.
+        dicefracdT(i) = 0.
+
+     ! If there is a cloud
+     ELSE
+        IF (cldfra(i) .GE. 1.0) THEN
+           cldfra1D = 1.0
+        END IF
+        
+        ! T>0°C, no ice allowed
+        IF ( temp(i) .GE. RTT ) THEN
+           qvap_cld(i)   = qsatl(i) * cldfra1D
+           qliq(i)       = MAX(0.0,qtot_incl(i)-qsatl(i))  * cldfra1D
+           qice(i)       = 0.
+           cldfraliq(i)  = 1.
+           icefrac(i)    = 0.
+           dicefracdT(i) = 0.
+        
+        ! T<-38°C, no liquid allowed
+        ELSE IF ( temp(i) .LE. temp_nowater) THEN
+           qvap_cld(i)   = qsati(i) * cldfra1D
+           qliq(i)       = 0.
+           qice(i)       = MAX(0.0,qtot_incl(i)-qsati(i)) * cldfra1D
+           cldfraliq(i)  = 0.
+           icefrac(i)    = 1.
+           dicefracdT(i) = 0.
+
+        ! MPC temperature
+        ELSE
+           ! Not enough TKE     
+           IF ( tke_dissip(i) .LE. eps )  THEN
+              qvap_cld(i)   = qsati(i) * cldfra1D
+              qliq(i)       = 0.
+              qice(i)       = MAX(0.,qtot_incl(i)-qsati(i)) * cldfra1D   
+              cldfraliq(i)  = 0.
+              icefrac(i)    = 1.
+              dicefracdT(i) = 0.
+           
+           ! Enough TKE   
+           ELSE  
+              print*,"MOUCHOIRACTIVE"
+              !---------------------------------------------------------
+              !--               ICE SUPERSATURATION PDF   
+              !--------------------------------------------------------- 
+              !--If -38°C< T <0°C and there is enough turbulence, 
+              !--we compute the cloud liquid properties with a Gaussian PDF 
+              !--of ice supersaturation F(Si) (Field2014, Furtado2016). 
+              !--Parameters of the PDF are function of turbulence and 
+              !--microphysics/existing ice.
+
+              sursat_iceliq = qsatl(i)/qsati(i) - 1.
+              psati         = qsati(i) * pplay(i) / (RD/RV)
+
+              !-------------- MICROPHYSICAL TERMS --------------
+              !--We assume an exponential ice PSD whose parameters 
+              !--are computed following Morrison&Gettelman 2008
+              !--Ice number density is assumed equals to INP density 
+              !--which is a function of temperature (DeMott 2010)  
+              !--bi and B0 are microphysical function characterizing 
+              !--vapor/ice interactions
+              !--tau_phase_relax is the typical time of vapor deposition
+              !--onto ice crystals
+              
+              qiceini_incl  = qice_ini(i) / cldfra1D
+              qsnowcld_incl = snowcld(i) * RG * dtime / ( paprsdn(i) - paprsup(i) ) / cldfra1D
+              sursat_env    = max(0., (qtot_incl(i) - qiceini_incl)/qsati(i) - 1.)
+              IF ( qiceini_incl .GT. eps ) THEN
+                nb_crystals = 1.e3 * 5.94e-5 * ( RTT - temp(i) )**3.33 * naero5**(0.0264*(RTT-temp(i))+0.0033)
+                lambda_PSD  = ( (RPI*rho_ice*nb_crystals) / (rho_air*(qiceini_incl + gamma_snwretro * qsnowcld_incl)) ) ** (1./3.)
+                N0_PSD      = nb_crystals * lambda_PSD
+                moment1_PSD = N0_PSD/lambda_PSD**2
+              ELSE
+                moment1_PSD = 0.
+              ENDIF
+
+              !--Formulae for air thermal conductivity and water vapor diffusivity 
+              !--comes respectively from Beard and Pruppacher (1971) 
+              !--and  Hall and Pruppacher (1976)
+
+              air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184
+              water_vapor_diff    = 2.11*1e-5 * ( temp(i) / RTT )**1.94 * ( 101325 / pplay(i) )
+              
+              bi = 1./((qsati(i)+qsatl(i))/2.) + RLSTT**2 / RCPD / RV / temp(i)**2
+              B0 = 4. * RPI * capa_crystal * 1. / (  RLSTT**2 / air_thermal_conduct / RV / temp(i)**2  &
+                                                  +  RV * temp(i) / psati / water_vapor_diff  )
+
+              invtau_phaserelax  = (bi * B0 * moment1_PSD )
+
+!             Old way of estimating moment1 : spherical crystals + monodisperse PSD              
+!             nb_crystals = rho_air * qiceini_incl / ( 4. / 3. * RPI * r_ice**3. * rho_ice )
+!             moment1_PSD = nb_crystals * r_ice 
+
+              !----------------- TURBULENT SOURCE/SINK TERMS -----------------
+              !--Tau_mixingenv is the time needed to homogeneize the parcel 
+              !--with its environment by turbulent diffusion over the parcel
+              !--length scale
+              !--if lmix_mpc <0, tau_mixigenv value is prescribed
+              !--else tau_mixigenv value is derived from tke_dissip and lmix_mpc
+              !--Tau_dissipturb is the time needed turbulence to decay due to
+              !--viscosity
+
+              ai = RG / RD / temp(i) * ( RD * RLSTT / RCPD / RV / temp(i) - 1. )
+              IF ( lmix_mpc .GT. 0 ) THEN 
+                 tau_mixingenv = ( lmix_mpc**2. / tke_dissip(i) )**(1./3.)
+              ELSE 
+                 tau_mixingenv = tau_mixenv
+              ENDIF 
+              
+              tau_dissipturb = gamma_taud * 2. * 2./3. * tke(i) / tke_dissip(i) / C0
+
+              !--------------------- PDF COMPUTATIONS ---------------------
+              !--Formulae for sigma2_pdf (variance), mean of PDF in Furtado2016
+              !--cloud liquid fraction and in-cloud liquid content are given 
+              !--by integrating resp. F(Si) and Si*F(Si)
+              !--Liquid is limited by the available water vapor trough a 
+              !--maximal liquid fraction
+
+              liqfra_max = MAX(0., (MIN (1.,( qtot_incl(i) - qiceini_incl - qsati(i) * (1 + sursat_iceext ) ) / ( qsatl(i) - qsati(i) ) ) ) )
+              sigma2_pdf = 1./2. * ( ai**2 ) *  2./3. * tke(i) * tau_dissipturb / ( invtau_phaserelax + 1./tau_mixingenv )
+              mean_pdf   = sursat_env * 1./tau_mixingenv / ( invtau_phaserelax + 1./tau_mixingenv )
+              cldfraliq(i) = 0.5 * (1. - erf( ( sursat_iceliq - mean_pdf) / (SQRT(2.* sigma2_pdf) ) ) )
+              IF (cldfraliq(i) .GT. liqfra_max) THEN
+                  cldfraliq(i) = liqfra_max
+              ENDIF 
+              
+              qliq_incl = qsati(i) * SQRT(sigma2_pdf) / SQRT(2.*RPI) * EXP( -1.*(sursat_iceliq - mean_pdf)**2. / (2.*sigma2_pdf) )  &
+                        - qsati(i) * cldfraliq(i) * (sursat_iceliq - mean_pdf )
+              
+              sigma2_icefracturb(i)= sigma2_pdf
+              mean_icefracturb(i)  = mean_pdf 
+     
+              !------------ SPECIFIC VAPOR CONTENT AND WATER CONSERVATION  ------------
+
+              IF ( (qliq_incl .LE. eps) .OR. (cldfraliq(i) .LE. eps) ) THEN
+                  qliq_incl    = 0.
+                  cldfraliq(i) = 0.
+              END IF
+               
+              !--Specific humidity is the max between qsati and the weighted mean between 
+              !--qv in MPC patches and qv in ice-only parts. We assume that MPC parts are
+              !--always at qsatl and ice-only parts slightly subsaturated (qsati*sursat_iceext+1)
+              !--The whole cloud can therefore be supersaturated but never subsaturated.
+
+              qvap_incl = MAX(qsati(i), ( 1. - cldfraliq(i) ) * (sursat_iceext + 1.) * qsati(i) + cldfraliq(i) * qsatl(i) )
+
+
+              IF ( qvap_incl  .GE. qtot_incl(i) ) THEN
+                 qvap_incl = qsati(i)
+                 qliq_incl = qtot_incl(i) - qvap_incl
+                 qice_incl = 0.
+
+              ELSEIF ( (qvap_incl + qliq_incl) .GE. qtot_incl(i) ) THEN
+                 qliq_incl = MAX(0.0,qtot_incl(i) - qvap_incl)
+                 qice_incl = 0.
+              ELSE
+                 qice_incl = qtot_incl(i) - qvap_incl - qliq_incl
+              END IF
+
+              qvap_cld(i)   = qvap_incl * cldfra1D
+              qliq(i)       = qliq_incl * cldfra1D
+              qice(i)       = qice_incl * cldfra1D
+              icefrac(i)    = qice(i) / ( qice(i) + qliq(i) )
+              dicefracdT(i) = 0.
+              !print*,'MPC turb'
+
+           END IF ! Enough TKE
+
+        END IF ! ! MPC temperature
+
+     END IF ! cldfra
+   
+   ENDDO ! klon
+END SUBROUTINE ICEFRAC_LSCP_TURB
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
 

LMDZ6/branches/cirrus/libf/phylmd/lmdz_thermcell_plume_6A.F90

@@ -63 +63 @@
       REAL,dimension(ngrid,nlay) :: zeps
 
-      REAL, dimension(ngrid) ::    wmaxa(ngrid)
+      REAL, dimension(ngrid) ::    wmaxa
 
       INTEGER ig,l,k,lt,it,lm

LMDZ6/branches/cirrus/libf/phylmd/ocean_forced_mod.F90

@@ -22 +22 @@
        radsol, snow, agesno, & 
        qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-       tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa)
+       tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa &
+#ifdef ISO
+       ,xtprecip_rain, xtprecip_snow, xtspechum,Roce,rlat, &
+       xtsnow,xtevap,h1 &  
+#endif            
+       )
 !
 ! This subroutine treats the "open ocean", all grid points that are not entierly covered
@@ -36 +41 @@
     USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o
     use config_ocean_skin_m, only: activate_ocean_skin
+#ifdef ISO
+    USE infotrac_phy, ONLY: ntiso,niso
+    USE isotopes_routines_mod, ONLY: calcul_iso_surf_oce_vectall, calcul_iso_surf_sic_vectall    
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,ridicule
+    !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,iso_verif_egalite_choix
+    USE isotopes_verif_mod
+#endif
+#endif
 
     INCLUDE "YOMCST.h"
@@ -57 +71 @@
     real, intent(in):: rhoa(:) ! (knon) density of moist air  (kg / m3)
 
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)  :: xtprecip_rain, xtprecip_snow
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)  :: xtspechum
+    REAL, DIMENSION(klon),       INTENT(IN)  :: rlat
+#endif
+
 ! In/Output arguments
 !****************************************************************************************
@@ -62 +82 @@
     REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
     REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno !? put to 0 in ocean
-  
+#ifdef ISO     
+    REAL, DIMENSION(niso,klon), INTENT(IN)   :: xtsnow
+    REAL, DIMENSION(niso,klon), INTENT(INOUT):: Roce
+#endif
+
 ! Output arguments
 !****************************************************************************************
@@ -72 +96 @@
     REAL, intent(out):: sens_prec_liq(:) ! (knon)
 
+#ifdef ISO     
+    REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap ! isotopes in evaporation flux
+    REAL, DIMENSION(klon),       INTENT(OUT) :: h1 ! just a diagnostic, not useful for the simulation
+#endif
+
 ! Local variables
 !****************************************************************************************
@@ -80 +109 @@
     REAL, DIMENSION(klon)       :: u1_lay, v1_lay
     LOGICAL                     :: check=.FALSE.
-    REAL sens_prec_sol(knon) 
-    REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol    
+    REAL, DIMENSION(knon)       :: sens_prec_sol
+    REAL, DIMENSION(klon)       :: lat_prec_liq, lat_prec_sol    
+#ifdef ISO   
+    REAL, PARAMETER :: t_coup = 273.15      
+#endif
+
 
 !****************************************************************************************
@@ -87 +120 @@
 !****************************************************************************************
     IF (check) WRITE(*,*)' Entering ocean_forced_noice'
-    
+
+#ifdef ISO
+#ifdef ISOVERIF
+    DO i = 1, knon
+      IF (iso_eau > 0) THEN         
+        CALL iso_verif_egalite_choix(xtspechum(iso_eau,i), &
+     &                  spechum(i),'ocean_forced_mod 111', &
+     &                  errmax,errmaxrel)     
+        CALL iso_verif_egalite_choix(snow(i), &
+     &                  xtsnow(iso_eau,i),'ocean_forced_mod 117', &
+     &                  errmax,errmaxrel)
+      ENDIF !IF (iso_eau > 0) THEN
+    ENDDO !DO i=1,knon
+#endif      
+#endif 
+
 !****************************************************************************************
 ! 1)    
@@ -103 +151 @@
 
     else ! GCM
-      CALL limit_read_sst(knon,knindex,tsurf_lim)
+      CALL limit_read_sst(knon,knindex,tsurf_lim &
+#ifdef ISO
+     &     ,Roce,rlat &
+#endif     
+     &     )
     endif ! knon
 !sb--
@@ -161 +213 @@
          flux_u1, flux_v1)  
 
+#ifdef ISO     
+    CALL calcul_iso_surf_oce_vectall(klon, knon,t_coup, &
+     &    ps,tsurf_new,spechum,u1_lay, v1_lay, xtspechum, &
+     &    evap, Roce,xtevap,h1 &
+#ifdef ISOTRAC
+     &    ,knindex &
+#endif
+     &    )
+#endif         
+
+#ifdef ISO
+#ifdef ISOVERIF
+!          write(*,*) 'ocean_forced_mod 176: sortie de ocean_forced_noice'
+    IF (iso_eau > 0) THEN
+      DO i = 1, knon               
+        CALL iso_verif_egalite_choix(snow(i), &
+     &          xtsnow(iso_eau,i),'ocean_forced_mod 180', &
+     &          errmax,errmaxrel)
+      ENDDO ! DO j=1,knon
+    ENDIF !IF (iso_eau > 0) THEN
+#endif
+#endif   
+
   END SUBROUTINE ocean_forced_noice
 !
@@ -173 +248 @@
        radsol, snow, qsol, agesno, tsoil, &
        qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-       tsurf_new, dflux_s, dflux_l, rhoa)
+       tsurf_new, dflux_s, dflux_l, rhoa &
+#ifdef ISO
+       ,xtprecip_rain, xtprecip_snow, xtspechum,Roce, &
+       xtsnow, xtsol,xtevap,Rland_ice &  
+#endif            
+       )
 !
 ! This subroutine treats the ocean where there is ice. 
@@ -187 +267 @@
     USE indice_sol_mod
     USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o
+#ifdef ISO
+    USE infotrac_phy, ONLY: niso, ntiso
+    USE isotopes_routines_mod, ONLY: calcul_iso_surf_oce_vectall, calcul_iso_surf_sic_vectall 
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,ridicule
+    !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,iso_verif_egalite_choix
+    USE isotopes_verif_mod
+#endif
+#endif
 
 !   INCLUDE "indicesol.h"
@@ -209 +298 @@
     REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
     real, intent(in):: rhoa(:) ! (knon) density of moist air  (kg / m3)
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow
+    REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum
+    REAL, DIMENSION(niso,klon),  INTENT(IN) :: Roce 
+    REAL, DIMENSION(niso,klon),  INTENT(IN) :: Rland_ice
+#endif
 
 ! In/Output arguments
@@ -216 +311 @@
     REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
     REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+#ifdef ISO     
+    REAL, DIMENSION(niso,klon), INTENT(INOUT)     :: xtsnow
+    REAL, DIMENSION(niso,klon), INTENT(IN)        :: xtsol
+#endif
 
 ! Output arguments
@@ -226 +325 @@
     REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
     REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+#ifdef ISO     
+    REAL, DIMENSION(ntiso,klon), INTENT(OUT)      :: xtevap
+#endif      
 
 ! Local variables
@@ -238 +340 @@
     REAL, DIMENSION(klon)       :: u0, v0
     REAL, DIMENSION(klon)       :: u1_lay, v1_lay
-    REAL sens_prec_liq(knon), sens_prec_sol (knon)   
+    REAL, DIMENSION(knon)       :: sens_prec_liq, sens_prec_sol
     REAL, DIMENSION(klon)       :: lat_prec_liq, lat_prec_sol    
 
+#ifdef ISO
+    REAL, PARAMETER :: t_coup = 273.15
+    REAL, DIMENSION(klon) :: fq_fonte_diag
+    REAL, DIMENSION(klon) :: fqfonte_diag
+    REAL, DIMENSION(klon) :: snow_evap_diag 
+    REAL, DIMENSION(klon) :: fqcalving_diag 
+    REAL, DIMENSION(klon) :: run_off_lic_diag
+    REAL :: coeff_rel_diag
+    REAL :: max_eau_sol_diag  
+    REAL, DIMENSION(klon) :: runoff_diag    
+    INTEGER IXT
+    REAL, DIMENSION(niso,klon) :: xtsnow_prec, xtsol_prec
+    REAL, DIMENSION(klon) :: snow_prec, qsol_prec  
+#endif
 
 !****************************************************************************************
@@ -307 +423 @@
 !
 !****************************************************************************************
+#ifdef ISO
+   ! verif
+#ifdef ISOVERIF
+    DO i = 1, knon
+      IF (iso_eau > 0) THEN
+        IF (snow(i) > ridicule) THEN
+          CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), &
+   &              'interfsurf 964',errmax,errmaxrel)
+        ENDIF !IF ((snow(i) > ridicule)) THEN
+      ENDIF !IF (iso_eau > 0) THEN      
+    ENDDO !DO i=1,knon  
+#endif
+   ! end verif
+
+    DO i = 1, knon
+      snow_prec(i) = snow(i)
+      DO ixt = 1, niso
+      xtsnow_prec(ixt,i) = xtsnow(ixt,i)
+      ENDDO !DO ixt=1,niso
+      ! initialisation:
+      fq_fonte_diag(i) = 0.0
+      fqfonte_diag(i)  = 0.0
+      snow_evap_diag(i)= 0.0
+    ENDDO !DO i=1,knon
+#endif
+
+
     CALL fonte_neige( knon, is_sic, knindex, dtime, &
          tsurf_tmp, precip_rain, precip_snow, &
-         snow, qsol, tsurf_new, evap)
+         snow, qsol, tsurf_new, evap &
+#ifdef ISO    
+     &  ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag   &
+     &  ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag   &
+#endif
+     &   )
+
+
+#ifdef ISO
+! isotopes: tout est externalisé
+!#ifdef ISOVERIF
+!        write(*,*) 'ocean_forced_mod 377: call calcul_iso_surf_sic_vectall'
+!        write(*,*) 'klon,knon=',klon,knon
+!#endif
+    CALL calcul_iso_surf_sic_vectall(klon,knon, &
+     &          evap,snow_evap_diag,Tsurf_new,Roce,snow, &
+     &          fq_fonte_diag,fqfonte_diag,dtime,t_coup, &
+     &          precip_snow,xtprecip_snow,xtprecip_rain, snow_prec,xtsnow_prec, &
+     &          xtspechum,spechum,ps, &
+     &          xtevap,xtsnow,fqcalving_diag, &
+     &          knindex,is_sic,run_off_lic_diag,coeff_rel_diag,Rland_ice &
+     &   )
+#ifdef ISOVERIF
+        !write(*,*) 'ocean_forced_mod 391: sortie calcul_iso_surf_sic_vectall'
+    IF (iso_eau > 0) THEN
+      DO i = 1, knon  
+        CALL iso_verif_egalite_choix(snow(i), &
+     &           xtsnow(iso_eau,i),'ocean_forced_mod 396', &
+     &           errmax,errmaxrel)
+      ENDDO ! DO j=1,knon
+    ENDIF !IF (iso_eau > 0) then
+#endif 
+!#ifdef ISOVERIF
+#endif   
+!#ifdef ISO
     
 ! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno)

LMDZ6/branches/cirrus/libf/phylmd/pbl_surface_mod.F90

@@ -33 +33 @@
                                   wx_pbl_check, wx_pbl_dts_check, wx_evappot
   use config_ocean_skin_m, only: activate_ocean_skin
+#ifdef ISO
+  USE infotrac_phy, ONLY: niso,ntraciso=>ntiso    
+#endif
 
   IMPLICIT NONE
@@ -49 +52 @@
   !$OMP THREADPRIVATE(ydTs0, ydqs0)
 
+#ifdef ISO
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: xtsnow   ! snow at surface
+  !$OMP THREADPRIVATE(xtsnow)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: Rland_ice   ! snow at surface
+  !$OMP THREADPRIVATE(Rland_ice)  
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: Roce   ! snow at surface
+  !$OMP THREADPRIVATE(Roce)  
+#endif
+
   INTEGER, SAVE :: iflag_pbl_surface_t2m_bug
   !$OMP THREADPRIVATE(iflag_pbl_surface_t2m_bug)
   INTEGER, SAVE :: iflag_new_t2mq2m
   !$OMP THREADPRIVATE(iflag_new_t2mq2m)
+  LOGICAL, SAVE :: ok_bug_zg_wk_pbl
+  !$OMP THREADPRIVATE(ok_bug_zg_wk_pbl)
 
 !FC
@@ -176 +190 @@
 
   END SUBROUTINE pbl_surface_init
+
+#ifdef ISO
+  SUBROUTINE pbl_surface_init_iso(xtsnow_rst,Rland_ice_rst)
+
+! This routine should be called after the restart file has been read.
+! This routine initialize the restart variables and does some validation tests
+! for the index of the different surfaces and tests the choice of type of ocean.
+
+    USE indice_sol_mod
+    USE print_control_mod, ONLY: lunout
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,ridicule
+    USE isotopes_verif_mod
+#endif
+    IMPLICIT NONE
+
+    INCLUDE "dimsoil.h"
+ 
+! Input variables
+!****************************************************************************************
+    REAL, DIMENSION(niso,klon, nbsrf), INTENT(IN)          :: xtsnow_rst
+    REAL, DIMENSION(niso,klon), INTENT(IN)          :: Rland_ice_rst
+  
+! Local variables
+!****************************************************************************************
+    INTEGER                       :: ierr
+    CHARACTER(len=80)             :: abort_message
+    CHARACTER(len = 20)           :: modname = 'pbl_surface_init'
+    integer i,ixt
+    
+!****************************************************************************************
+! Allocate and initialize module variables with fields read from restart file.
+!
+!****************************************************************************************    
+
+    ALLOCATE(xtsnow(niso,klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(Rland_ice(niso,klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(Roce(niso,klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    xtsnow(:,:,:)  = xtsnow_rst(:,:,:)
+    Rland_ice(:,:) = Rland_ice_rst(:,:)
+    Roce(:,:)      = 0.0
+
+#ifdef ISOVERIF 
+      IF (iso_eau >= 0) THEN
+         CALL iso_verif_egalite_vect2D( &
+     &           xtsnow,snow, &
+     &           'pbl_surface_mod 170',niso,klon,nbsrf)
+         DO i=1,klon  
+            IF (iso_eau >= 0) THEN  
+              CALL iso_verif_egalite(Rland_ice(iso_eau,i),1.0, &
+     &         'pbl_surf_mod 177')
+            ENDIF
+         ENDDO
+      ENDIF
+#endif
+
+  END SUBROUTINE pbl_surface_init_iso
+#endif
+
 !  
 !****************************************************************************************
@@ -239 +318 @@
 !FC
 !!!
-                        )
+#ifdef ISO
+     &   ,xtrain_f, xtsnow_f,xt, &
+     &   wake_dlxt,zxxtevap,xtevap, &
+     &   d_xt,d_xt_w,d_xt_x, &
+     &   xtsol,dflux_xt,zxxtsnow,zxfluxxt,flux_xt, &
+     &   h1_diag,runoff_diag,xtrunoff_diag &
+#endif      
+     &   )
 !****************************************************************************************
 ! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
@@ -314 +400 @@
     USE mod_grid_phy_lmdz,  ONLY : nbp_lon, nbp_lat, grid1dto2d_glo
     USE print_control_mod,  ONLY : prt_level,lunout
+#ifdef ISO
+  USE isotopes_mod, ONLY: Rdefault,iso_eau
+#ifdef ISOVERIF
+        USE isotopes_verif_mod
+#endif
+#ifdef ISOTRAC
+        USE isotrac_mod, only: index_iso
+#endif
+#endif
     USE ioipsl_getin_p_mod, ONLY : getin_p
     use phys_state_var_mod, only: ds_ns, dt_ns, delta_sst, delta_sal, dter, &
@@ -366 +461 @@
     REAL, DIMENSION(klon),        INTENT(IN)        :: gustiness ! gustiness
 
-    REAL, DIMENSION(klon),        INTENT(IN)        :: cldt    ! total cloud fraction
+    REAL, DIMENSION(klon),        INTENT(IN)        :: cldt    ! total cloud 
+
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon,klev),   INTENT(IN)        :: xt       ! water vapour (kg/kg)
+    REAL, DIMENSION(ntraciso,klon),        INTENT(IN)        :: xtrain_f  ! rain fall
+    REAL, DIMENSION(ntraciso,klon),        INTENT(IN)        :: xtsnow_f  ! snow fall
+#endif
 
 !!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
@@ -379 +480 @@
     REAL, DIMENSION(klon),        INTENT(IN)        :: wake_dens
 !!!
-
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon,klev),   INTENT(IN)        :: wake_dlxt   
+#endif
 ! Input/Output variables
 !****************************************************************************************
@@ -448 +551 @@
     REAL, INTENT(OUT):: zcoefm(:, :, :) ! (klon, klev, nbsrf + 1)
     ! coef for turbulent diffusion of U and V (?), mean for each grid point
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon),        INTENT(OUT)       :: zxxtevap     ! water vapour flux at surface, positiv upwards
+    REAL, DIMENSION(ntraciso,klon, klev),  INTENT(OUT)       :: d_xt        ! change in water vapour
+    REAL, DIMENSION(klon),                 INTENT(OUT)       :: runoff_diag
+    REAL, DIMENSION(niso,klon),            INTENT(OUT)       :: xtrunoff_diag
+    REAL, DIMENSION(ntraciso,klon,klev),   INTENT(OUT)       :: d_xt_w
+    REAL, DIMENSION(ntraciso,klon,klev),   INTENT(OUT)       :: d_xt_x
+#endif
+
+
 
 !!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
@@ -511 +624 @@
     REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v     ! v wind tension (kg m/s)/(m**2 s) or Pascal
 !FC
-    REAL, DIMENSION(klon, klev, nbsrf), INTENT(INOUT)  :: treedrg      ! tree drag (m)               
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(INOUT) :: treedrg  ! tree drag (m)               
+#ifdef ISO        
+    REAL, DIMENSION(niso,klon),   INTENT(OUT)       :: xtsol      ! water height in the soil (mm)
+    REAL, DIMENSION(ntraciso,klon, nbsrf)           :: xtevap     ! evaporation at surface
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: h1_diag    ! just diagnostic, not useful
+#endif
 
 
@@ -525 +643 @@
     REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_qbs   ! blowind snow vertical flux (kg/m**2
 
+#ifdef ISO   
+    REAL, DIMENSION(ntraciso,klon),              INTENT(OUT) :: dflux_xt    ! change of water vapour flux
+    REAL, DIMENSION(niso,klon),                  INTENT(OUT) :: zxxtsnow    ! snow at surface, mean for each grid point
+    REAL, DIMENSION(ntraciso,klon, klev),        INTENT(OUT) :: zxfluxxt    ! water vapour flux, mean for each grid point 
+    REAL, DIMENSION(ntraciso,klon, klev, nbsrf), INTENT(OUT) :: flux_xt     ! water vapour flux(latent flux) (kg/m**2/s)  
+#endif
 
 ! Martin
@@ -573 +697 @@
     REAL, DIMENSION(klon)              :: ysnow, yqsurf, yagesno, yqsol
     REAL, DIMENSION(klon)              :: yrain_f, ysnow_f, ybs_f
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon)     :: yxt1
+    REAL, DIMENSION(niso,klon)         :: yxtsnow, yxtsol   
+    REAL, DIMENSION(ntraciso,klon)     :: yxtrain_f, yxtsnow_f 
+    REAL, DIMENSION(klon)              :: yrunoff_diag
+    REAL, DIMENSION(niso,klon)         :: yxtrunoff_diag
+    REAL, DIMENSION(niso,klon)         :: yRland_ice    
+#endif
     REAL, DIMENSION(klon)              :: ysolsw, ysollw
     REAL, DIMENSION(klon)              :: yfder
@@ -581 +713 @@
     REAL, DIMENSION(klon)              :: y_flux_t1, y_flux_q1
     REAL, DIMENSION(klon)              :: y_dflux_t, y_dflux_q
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon)     ::  y_flux_xt1
+    REAL, DIMENSION(ntraciso,klon)     ::  y_dflux_xt
+#endif
     REAL, DIMENSION(klon)              :: y_flux_u1, y_flux_v1
     REAL, DIMENSION(klon)              :: y_flux_bs, y_flux0
@@ -608 +744 @@
     REAL, DIMENSION(klon)              :: AcoefH_0, AcoefQ_0, BcoefH_0, BcoefQ_0
     REAL, DIMENSION(klon)              :: AcoefH, AcoefQ, BcoefH, BcoefQ
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon)     :: AcoefXT, BcoefXT
+#endif
     REAL, DIMENSION(klon)              :: AcoefU, AcoefV, BcoefU, BcoefV
     REAL, DIMENSION(klon)              :: AcoefQBS, BcoefQBS
@@ -626 +765 @@
     REAL, DIMENSION(klon,klev)         :: yu, yv
     REAL, DIMENSION(klon,klev)         :: yt, yq, yqbs
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon)      :: yxtevap
+    REAL, DIMENSION(ntraciso,klon,klev) :: y_d_xt
+    REAL, DIMENSION(ntraciso,klon,klev) :: y_flux_xt
+    REAL, DIMENSION(ntraciso,klon,klev) :: yxt   
+#endif
     REAL, DIMENSION(klon,klev)         :: ypplay, ydelp
     REAL, DIMENSION(klon,klev)         :: delp
@@ -697 +842 @@
     REAL, DIMENSION(klon,klev)         :: Kcoef_hq_w, Kcoef_m_w, gama_h_w, gama_q_w
     REAL, DIMENSION(klon)              :: alf_1, alf_2, alf_1_x, alf_2_x, alf_1_w, alf_2_w
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon,klev)         :: yxt_x, yxt_w
+    REAL, DIMENSION(ntraciso,klon)              :: y_flux_xt1_x , y_flux_xt1_w   
+    REAL, DIMENSION(ntraciso,klon,klev)         :: y_flux_xt_x,y_d_xt_x,zxfluxxt_x
+    REAL, DIMENSION(ntraciso,klon,klev)         :: y_flux_xt_w,y_d_xt_w,zxfluxxt_w
+    REAL, DIMENSION(ntraciso,klon,klev,nbsrf)   :: flux_xt_x, flux_xt_w
+    REAL, DIMENSION(ntraciso,klon)              :: AcoefXT_x, BcoefXT_x
+    REAL, DIMENSION(ntraciso,klon)              :: AcoefXT_w, BcoefXT_w
+    REAL, DIMENSION(ntraciso,klon,klev)         :: CcoefXT, DcoefXT
+    REAL, DIMENSION(ntraciso,klon,klev)         :: CcoefXT_x, DcoefXT_x
+    REAL, DIMENSION(ntraciso,klon,klev)         :: CcoefXT_w, DcoefXT_w
+    REAL, DIMENSION(ntraciso,klon,klev)         :: gama_xt,gama_xt_x,gama_xt_w
+#endif
 !!!
 !!!jyg le 08/02/2012
@@ -889 +1047 @@
     REAL, DIMENSION(klon)              :: yrmu0
     ! Martin
-    REAL, DIMENSIOn(klon)              :: yri0
+    REAL, DIMENSION(klon)              :: yri0
 
     REAL, DIMENSION(klon):: ydelta_sst, ydelta_sal, yds_ns, ydt_ns, ydter, &
@@ -896 +1054 @@
     ! dt_ds, tkt, tks, taur, sss on ocean points
     REAL :: missing_val
+#ifdef ISO
+    REAL, DIMENSION(klon)       :: h1
+    INTEGER                     :: ixt
+!#ifdef ISOVERIF
+!    integer iso_verif_positif_nostop
+!#endif    
+#endif
+
 !****************************************************************************************
 ! End of declarations
@@ -924 +1090 @@
       iflag_split = iflag_split_ref
 
+#ifdef ISO      
+#ifdef ISOVERIF
+      DO i=1,klon
+        DO ixt=1,niso
+          CALL iso_verif_noNaN(xtsol(ixt,i),'pbl_surface 608')
+        ENDDO
+      ENDDO
+#endif
+#ifdef ISOVERIF
+      DO i=1,klon  
+        IF (iso_eau >= 0) THEN  
+          CALL iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, &
+     &         'pbl_surf_mod 585',errmax,errmaxrel)
+          CALL iso_verif_egalite_choix(xtsnow_f(iso_eau,i),snow_f(i), &
+     &         'pbl_surf_mod 594',errmax,errmaxrel)
+          IF (iso_verif_egalite_choix_nostop(xtsol(iso_eau,i),qsol(i), &
+     &         'pbl_surf_mod 596',errmax,errmaxrel) == 1) THEN
+                WRITE(*,*) 'i=',i
+                STOP
+          ENDIF
+          DO nsrf=1,nbsrf
+            CALL iso_verif_egalite_choix(xtsnow(iso_eau,i,nsrf),snow(i,nsrf), &
+     &         'pbl_surf_mod 598',errmax,errmaxrel)
+          ENDDO
+        ENDIF !IF (iso_eau >= 0) THEN   
+      ENDDO !DO i=1,knon  
+      DO k=1,klev
+        DO i=1,klon  
+          IF (iso_eau >= 0) THEN  
+            CALL iso_verif_egalite_choix(xt(iso_eau,i,k),q(i,k), &
+     &           'pbl_surf_mod 595',errmax,errmaxrel)
+          ENDIF !IF (iso_eau >= 0) THEN  
+        ENDDO !DO i=1,knon  
+      ENDDO !DO k=1,klev
+#endif
+#endif
+
+
 !****************************************************************************************
 ! 1) Initialisation and validation tests 
@@ -935 +1139 @@
        CALL getin_p('iflag_new_t2mq2m',iflag_new_t2mq2m)
        WRITE(lunout,*) 'pbl_iflag_new_t2mq2m=',iflag_new_t2mq2m
+
+       ok_bug_zg_wk_pbl=.TRUE.
+       CALL getin_p('ok_bug_zg_wk_pbl',ok_bug_zg_wk_pbl)
+       WRITE(lunout,*) 'ok_bug_zg_wk_pbl=',ok_bug_zg_wk_pbl
 
        print*,'PBL SURFACE AVEC GUSTINESS'
@@ -984 +1192 @@
       PRINT*,'WARNING : On impose qsol=',qsol0
       qsol(:)=qsol0
+#ifdef ISO
+      DO ixt=1,niso
+        xtsol(ixt,:)=qsol0*Rdefault(ixt)
+      ENDDO
+#ifdef ISOTRAC      
+      DO ixt=1+niso,ntraciso
+        xtsol(ixt,:)=qsol0*Rdefault(index_iso(ixt))
+      ENDDO
+#endif       
+#endif
     ENDIF
 !****************************************************************************************
@@ -1034 +1252 @@
  qsnow(:)=0. ; snowhgt(:)=0. ; to_ice(:)=0. ; sissnow(:)=0.
  runoff(:)=0.
+#ifdef ISO
+zxxtevap(:,:)=0.
+ d_xt(:,:,:)=0. 
+ d_xt_x(:,:,:)=0.
+ d_xt_w(:,:,:)=0.
+ flux_xt(:,:,:,:)=0. 
+! xtsnow(:,:,:)=0.! attention, xtsnow est l'équivalent de snow et non de qsnow
+ xtevap(:,:,:)=0.
+#endif
     IF (iflag_pbl<20.or.iflag_pbl>=30) THEN
        zcoefh(:,:,:) = 0.0
@@ -1123 +1350 @@
 !FC
 
+#ifdef ISO
+   yxtrain_f = 0.0 ; yxtsnow_f = 0.0
+   yxtsnow  = 0.0
+   yxt = 0.0
+   yxtsol = 0.0
+   flux_xt = 0.0
+   yRland_ice = 0.0
+!   d_xt = 0.0      
+   y_dflux_xt = 0.0  
+   dflux_xt=0.0 
+   y_d_xt_x=0.      ; y_d_xt_w=0.       
+#endif 
+
 ! >> PC
 !the yfields_out variable is defined in (klon,nbcf_out) even if it is used on
@@ -1149 +1389 @@
     fluxlat_x(:,:)=0. ;           fluxlat_w(:,:)=0. 
 !>jyg
+#ifdef ISO
+    flux_xt_x(:,:,:,:)=0. ;          flux_xt_w(:,:,:,:)=0.
+#endif
 !
 !jyg<
@@ -1448 +1691 @@
           yfluxbs(j)=0.0
           y_flux_bs(j) = 0.0
+!!!
+#ifdef ISO
+          DO ixt=1,ntraciso
+            yxtrain_f(ixt,j) = xtrain_f(ixt,i)
+            yxtsnow_f(ixt,j) = xtsnow_f(ixt,i)  
+          ENDDO
+          DO ixt=1,niso
+            yxtsnow(ixt,j)   = xtsnow(ixt,i,nsrf)
+          ENDDO    
+          !IF (nsrf == is_lic) THEN
+          DO ixt=1,niso
+            yRland_ice(ixt,j)= Rland_ice(ixt,i)  
+          ENDDO    
+          !endif !IF (nsrf == is_lic) THEN
+#ifdef ISOVERIF
+          IF (iso_eau >= 0) THEN
+              call iso_verif_egalite_choix(ysnow_f(j), &
+     &          yxtsnow_f(iso_eau,j),'pbl_surf_mod 862', &
+     &          errmax,errmaxrel)
+              call iso_verif_egalite_choix(ysnow(j), &
+     &          yxtsnow(iso_eau,j),'pbl_surf_mod 872', &
+     &          errmax,errmaxrel)
+          ENDIF
+#endif
+#ifdef ISOVERIF
+         DO ixt=1,ntraciso
+           call iso_verif_noNaN(yxtsnow_f(ixt,j),'pbl_surf_mod 921')
+         ENDDO
+#endif
+#endif
        ENDDO
 ! >> PC
@@ -1487 +1760 @@
              yq(j,k) = q(i,k)
              yqbs(j,k)=qbs(i,k)
+#ifdef ISO
+             DO ixt=1,ntraciso   
+               yxt(ixt,j,k) = xt(ixt,i,k)
+             ENDDO !DO ixt=1,ntraciso
+#endif
           ENDDO
         ENDDO
@@ -1504 +1782 @@
              yq_w(j,k) = q(i,k)+(1.-wake_s(i))*wake_dlq(i,k)
 !!!
+#ifdef ISO
+             DO ixt=1,ntraciso
+               yxt_x(ixt,j,k) = xt(ixt,i,k)-wake_s(i)*wake_dlxt(ixt,i,k)
+               yxt_w(ixt,j,k) = xt(ixt,i,k)+(1.-wake_s(i))*wake_dlxt(ixt,i,k)
+             ENDDO
+#endif
           ENDDO
         ENDDO
@@ -1559 +1843 @@
              i = ni(j)
              yqsol(j) = qsol(i)
+#ifdef ISO
+             DO ixt=1,niso
+               yxtsol(ixt,j) = xtsol(ixt,i)
+             ENDDO
+#endif
           ENDDO
        ENDIF
@@ -1664 +1953 @@
             ycdragm_w, ycdragh_w, zri1_w, pref_w, rain_f, zxtsol, ypplay(:,1) )
 !
-!!!bug !!        zgeo1(:) = wake_s(:)*zgeo1_w(:) + (1.-wake_s(:))*zgeo1_x(:)
-        zgeo1(1:knon) = wake_s(1:knon)*zgeo1_w(1:knon) + (1.-wake_s(1:knon))*zgeo1_x(1:knon)
+        IF(ok_bug_zg_wk_pbl) THEN
+         zgeo1(1:knon) = wake_s(1:knon)*zgeo1_w(1:knon) + (1.-wake_s(1:knon))*zgeo1_x(1:knon)
+        ELSE
+         zgeo1(1:knon) = ywake_s(1:knon)*zgeo1_w(1:knon) + (1.-ywake_s(1:knon))*zgeo1_x(1:knon)
+        ENDIF
 
 ! --- special Dice. JYG+MPL 25112013 puis BOMEX
@@ -1704 +1996 @@
 
         IF (iflag_pbl>=50) THEN
-        CALL call_atke(dtime,knon,klev,ycdragm(1:knon), ycdragh(1:knon),yus0(1:knon),yvs0(1:knon),yts(1:knon), &
+        CALL call_atke(dtime,knon,klev,nsrf,ni,ycdragm(1:knon), ycdragh(1:knon),yus0(1:knon),yvs0(1:knon),yts(1:knon), &
                   yu(1:knon,:),yv(1:knon,:),yt(1:knon,:),yq(1:knon,:),ypplay(1:knon,:),ypaprs(1:knon,:),       &
                   ytke(1:knon,:),yeps(1:knon,:), ycoefm(1:knon,:), ycoefh(1:knon,:))
@@ -1749 +2041 @@
         IF (iflag_pbl>=50) THEN
      
-        CALL call_atke(dtime,knon,klev,ycdragm_x(1:knon),ycdragh_x(1:knon),yus0(1:knon),yvs0(1:knon),yts_x(1:knon),    &
+        CALL call_atke(dtime,knon,klev,nsrf,ni,ycdragm_x(1:knon),ycdragh_x(1:knon),yus0(1:knon),yvs0(1:knon),yts_x(1:knon),    &
                        yu_x(1:knon,:),yv_x(1:knon,:),yt_x(1:knon,:),yq_x(1:knon,:),ypplay(1:knon,:),ypaprs(1:knon,:),  &
                        ytke_x(1:knon,:),yeps_x(1:knon,:),ycoefm_x(1:knon,:), ycoefh_x(1:knon,:))
@@ -1789 +2081 @@
         IF (iflag_pbl>=50) THEN
         
-        CALL call_atke(dtime,knon,klev,ycdragm_w(1:knon),ycdragh_w(1:knon),yus0(1:knon),yvs0(1:knon),yts_w(1:knon), &
+        CALL call_atke(dtime,knon,klev,nsrf,ni,ycdragm_w(1:knon),ycdragh_w(1:knon),yus0(1:knon),yvs0(1:knon),yts_w(1:knon), &
                 yu_w(1:knon,:),yv_w(1:knon,:),yt_w(1:knon,:),yq_w(1:knon,:),ypplay(1:knon,:),ypaprs(1:knon,:),      &
                 ytke_w(1:knon,:),yeps_w(1:knon,:),ycoefm_w(1:knon,:),ycoefh_w(1:knon,:))
@@ -1850 +2142 @@
             Kcoef_hq, gama_q, gama_h, &
 !!!
-            AcoefH, AcoefQ, BcoefH, BcoefQ)
+            AcoefH, AcoefQ, BcoefH, BcoefQ &
+#ifdef ISO
+         &   ,yxt, CcoefXT, DcoefXT, gama_xt, AcoefXT, BcoefXT & 
+#endif               
+         &   )
        ELSE  !(iflag_split .eq.0)
         CALL climb_hq_down(knon, ycoefh_x, ypaprs, ypplay, &
@@ -1858 +2154 @@
             Kcoef_hq_x, gama_q_x, gama_h_x, &
 !!!
-            AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x)
+            AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x &
+#ifdef ISO
+         &   ,yxt_x, CcoefXT_x, DcoefXT_x, gama_xt_x, AcoefXT_x, BcoefXT_x & 
+#endif               
+         &   )
 !!!
        IF (prt_level >=10) THEN
@@ -1873 +2173 @@
             Kcoef_hq_w, gama_q_w, gama_h_w, &
 !!!
-            AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w)
+            AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w &
+#ifdef ISO
+         &   ,yxt_w, CcoefXT_w, DcoefXT_w, gama_xt_w, AcoefXT_w, BcoefXT_w & 
+#endif               
+         &   )
 !!!
        IF (prt_level >=10) THEN
@@ -1955 +2259 @@
          yt1(:) = yt(:,1)
          yq1(:) = yq(:,1)
+#ifdef ISO
+         yxt1(:,:) = yxt(:,:,1)
+#endif
+
        ELSE IF (iflag_split .ge. 1) THEN
+#ifdef ISO
+        call abort_gcm('pbl_surface_mod 2149','isos pas encore dans iflag_split=1',1)
+#endif
+
 !
 ! Cdragq computation
@@ -2117 +2429 @@
                yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, &
                y_flux_u1, y_flux_v1, &
-               yveget,ylai,yheight )
+               yveget,ylai,yheight   &
+#ifdef ISO
+         &      ,yxtrain_f, yxtsnow_f,yxt1, &
+         &      yxtsnow,yxtsol,yxtevap,h1, &
+         &      yrunoff_diag,yxtrunoff_diag,yRland_ice &
+#endif               
+         &      )
  
 !FC quid qd yveget ylai yheight ne sont pas definit
@@ -2147 +2465 @@
           ENDDO
       ENDIF
-     
+
+#ifdef ISOVERIF
+        DO j=1,knon
+          DO ixt=1,ntraciso
+            CALL iso_verif_noNaN(yxtevap(ixt,j), &
+         &      'pbl_surface 1056a: apres surf_land')
+          ENDDO
+          DO ixt=1,niso
+            CALL iso_verif_noNaN(yxtsol(ixt,j), &
+         &      'pbl_surface 1056b: apres surf_land')
+          ENDDO
+        ENDDO
+#endif
+#ifdef ISOVERIF
+!        write(*,*) 'pbl_surface_mod 1038: sortie surf_land'
+        DO j=1,knon
+          IF (iso_eau >= 0) THEN     
+                 CALL iso_verif_egalite(yxtsnow(iso_eau,j), &
+     &                                  ysnow(j),'pbl_surf_mod 1043')
+          ENDIF !if (iso_eau.gt.0) then
+        ENDDO !DO i=1,klon
+#endif
+    
        CASE(is_lic)
           ! Martin
@@ -2168 +2508 @@
                   ysnowhgt, yqsnow, ytoice, ysissnow, &
                   yalb3_new, yrunoff, &
-                  y_flux_u1, y_flux_v1)
+                  y_flux_u1, y_flux_v1 &
+#ifdef ISO
+                  &    ,yxtrain_f, yxtsnow_f,yxt1,yRland_ice &
+                  &    ,yxtsnow,yxtsol,yxtevap &
+#endif              
+                  &    )
              
              !jyg<
@@ -2190 +2535 @@
                 ENDDO
              ENDIF
-             
+
+#ifdef ISOVERIF
+             DO j=1,knon
+               DO ixt=1,ntraciso
+                 CALL iso_verif_noNaN(yxtevap(ixt,j), &
+                        &             'pbl_surface 1095a: apres surf_landice')
+               ENDDO
+                do ixt=1,niso
+                   call iso_verif_noNaN(yxtsol(ixt,j), &
+                        &      'pbl_surface 1095b: apres surf_landice')
+                enddo
+             enddo
+#endif
+#ifdef ISOVERIF
+             !write(*,*) 'pbl_surface_mod 1060: sortie surf_landice'
+             do j=1,knon
+               IF (iso_eau >= 0) THEN     
+                 CALL iso_verif_egalite(yxtsnow(iso_eau,j), &
+                        &               ysnow(j),'pbl_surf_mod 1064')
+               ENDIF !if (iso_eau >= 0) THEN
+             ENDDO !DO i=1,klon
+#endif
+            
           END IF
           
@@ -2207 +2574 @@
                y_flux_u1, y_flux_v1, ydelta_sst(:knon), ydelta_sal(:knon), &
                yds_ns(:knon), ydt_ns(:knon), ydter(:knon), ydser(:knon), &
-               ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss)
+               ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss &
+#ifdef ISO
+         &      ,yxtrain_f, yxtsnow_f,yxt1,Roce, &
+         &      yxtsnow,yxtevap,h1 &
+#endif               
+         &      )
       IF (prt_level >=10) THEN
           print *,'arg de surf_ocean: ycdragh ',ycdragh(1:knon)
@@ -2248 +2620 @@
 !albedo SB <<<
                ytsurf_new, y_dflux_t, y_dflux_q, &
-               y_flux_u1, y_flux_v1)
+               y_flux_u1, y_flux_v1 &
+#ifdef ISO
+         &      ,yxtrain_f, yxtsnow_f,yxt1,Roce, &
+         &      yxtsnow,yxtsol,yxtevap,Rland_ice &
+#endif               
+         &      )
           
 ! Special DICE MPL 05082013 puis BOMEX MPL 20150410
@@ -2256 +2633 @@
           y_flux_v1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yv(j,1)*ypplay(j,1)/RD/yt(j,1)
           ENDDO
-      ENDIF
+       ENDIF
+
+#ifdef ISOVERIF
+        DO j=1,knon
+          DO ixt=1,ntraciso
+            CALL iso_verif_noNaN(yxtevap(ixt,j), &
+         &                       'pbl_surface 1165a: apres surf_seaice')
+          ENDDO
+          DO ixt=1,niso
+            CALL iso_verif_noNaN(yxtsol(ixt,j), &
+         &      'pbl_surface 1165b: apres surf_seaice')
+          ENDDO
+        ENDDO
+#endif
+#ifdef ISOVERIF
+        !write(*,*) 'pbl_surface_mod 1077: sortie surf_seaice'
+        DO j=1,knon
+          IF (iso_eau >= 0) THEN     
+                 CALL iso_verif_egalite(yxtsnow(iso_eau,j), &
+     &                                  ysnow(j),'pbl_surf_mod 1106')
+          ENDIF !IF (iso_eau >= 0) THEN
+        ENDDO !DO i=1,klon
+#endif
 
        CASE DEFAULT
@@ -2316 +2715 @@
             yt1_new=(1./RCPD)*(AcoefH(j)+BcoefH(j)*y_flux_t1(j)*dtime)
             ytsurf_new(j)=yt1_new-y_flux_t1(j)/(Kech_h(j)*RCPD)
+            ! for cases forced in flux and for which forcing in Ts is needed
+            ! to prevent the latter to reach unrealistic value (even if not used,
+            ! Ts is calculated and hgardfou can appear during the calculation
+            ! of surface saturation humidity for example
+            if (ok_forc_tsurf) ytsurf_new(j)=tg
           ENDDO
 
@@ -2326 +2730 @@
           y_flux_t1(j) =  yfluxsens(j)
           y_flux_q1(j) = -yevap(j)
+#ifdef ISO
+          y_flux_xt1(:,:) = -yxtevap(:,:)
+#endif
           ENDDO
         ENDIF ! (ok_flux_surf)
@@ -2341 +2748 @@
 
        IF (iflag_split .GE. 1) THEN
+#ifdef ISO
+        call abort_gcm('pbl_surface_mod 2607','isos pas encore dans iflag_split=1',1)
+#endif
+!
 !
          IF (nsrf .ne. is_oce) THEN
@@ -2558 +2969 @@
             Kcoef_hq, gama_q, gama_h, &
 !!!
-            y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:))    
+            y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:) &
+#ifdef ISO
+        &    ,yxt,y_flux_xt1 &
+        &    ,AcoefXT,BcoefXT,CcoefXT,DcoefXT,gama_xt &
+        &    ,y_flux_xt(:,:,:),y_d_xt(:,:,:) &
+#endif
+        &    )    
        ELSE  !(iflag_split .eq.0)
         CALL climb_hq_up(knon, dtime, yt_x, yq_x, &
@@ -2567 +2984 @@
             Kcoef_hq_x, gama_q_x, gama_h_x, &
 !!!
-            y_flux_q_x(:,:), y_flux_t_x(:,:), y_d_q_x(:,:), y_d_t_x(:,:))    
+            y_flux_q_x(:,:), y_flux_t_x(:,:), y_d_q_x(:,:), y_d_t_x(:,:) &
+#ifdef ISO
+        &    ,yxt_x,y_flux_xt1_x &
+        &    ,AcoefXT_x,BcoefXT_x,CcoefXT_x,DcoefXT_x,gama_xt_x &
+        &    ,y_flux_xt_x(:,:,:),y_d_xt_x(:,:,:) &
+#endif
+        &    )    
 !
        CALL climb_hq_up(knon, dtime, yt_w, yq_w, &
@@ -2576 +2999 @@
             Kcoef_hq_w, gama_q_w, gama_h_w, &
 !!!
-            y_flux_q_w(:,:), y_flux_t_w(:,:), y_d_q_w(:,:), y_d_t_w(:,:))    
+            y_flux_q_w(:,:), y_flux_t_w(:,:), y_d_q_w(:,:), y_d_t_w(:,:) &
+#ifdef ISO
+        &    ,yxt_w,y_flux_xt1_w &
+        &    ,AcoefXT_w,BcoefXT_w,CcoefXT_w,DcoefXT_w,gama_xt_w &
+        &    ,y_flux_xt_w(:,:,:),y_d_xt_w(:,:,:) &
+#endif
+        &    )    
 !!!
        ENDIF  ! (iflag_split .eq.0)
@@ -2694 +3123 @@
              flux_u(i,k,nsrf) = y_flux_u(j,k)
              flux_v(i,k,nsrf) = y_flux_v(j,k)
+
+#ifdef ISO
+             DO ixt=1,ntraciso
+                y_d_xt(ixt,j,k)  = y_d_xt(ixt,j,k) * ypct(j)
+                flux_xt(ixt,i,k,nsrf) = y_flux_xt(ixt,j,k)
+             ENDDO ! DO ixt=1,ntraciso
+             h1_diag(i)=h1(j)
+#endif
+
            ENDDO
         ENDDO
+
+#ifdef ISO
+#ifdef ISOVERIF
+        if (iso_eau.gt.0) then
+         call iso_verif_egalite_vect2D( &
+                y_d_xt,y_d_q, &
+                'pbl_surface_mod 2600',ntraciso,klon,klev)
+        endif       
+#endif
+#endif
 
        ELSE  !(iflag_split .eq.0)
@@ -2713 +3161 @@
             flux_u_x(i,k,nsrf) = y_flux_u_x(j,k)
             flux_v_x(i,k,nsrf) = y_flux_v_x(j,k)
+
+#ifdef ISO
+            DO ixt=1,ntraciso
+              y_d_xt_x(ixt,j,k)  = y_d_xt_x(ixt,j,k) * ypct(j)
+              flux_xt_x(ixt,i,k,nsrf) = y_flux_xt_x(ixt,j,k)
+            ENDDO ! DO ixt=1,ntraciso
+#endif
           ENDDO
         ENDDO
@@ -2730 +3185 @@
             flux_u_w(i,k,nsrf) = y_flux_u_w(j,k)
             flux_v_w(i,k,nsrf) = y_flux_v_w(j,k)
+
+#ifdef ISO
+            DO ixt=1,ntraciso
+              y_d_xt_w(ixt,j,k)  = y_d_xt_w(ixt,j,k) * ypct(j)
+              flux_xt_w(ixt,i,k,nsrf) = y_flux_xt_w(ixt,j,k)
+            ENDDO ! do ixt=1,ntraciso
+#endif
+
           ENDDO
         ENDDO
@@ -2741 +3204 @@
             flux_u(i,k,nsrf) = flux_u_x(i,k,nsrf)+ywake_s(j)*(flux_u_w(i,k,nsrf)-flux_u_x(i,k,nsrf))
             flux_v(i,k,nsrf) = flux_v_x(i,k,nsrf)+ywake_s(j)*(flux_v_w(i,k,nsrf)-flux_v_x(i,k,nsrf))
+#ifdef ISO
+            DO ixt=1,ntraciso
+              flux_xt(ixt,i,k,nsrf) = flux_xt_x(ixt,i,k,nsrf)+ywake_s(j)*(flux_xt_w(ixt,i,k,nsrf)-flux_xt_x(ixt,i,k,nsrf))
+            ENDDO ! do ixt=1,ntraciso
+#endif
           ENDDO
         ENDDO
@@ -2798 +3266 @@
           dflux_t(i) = dflux_t(i) + y_dflux_t(j)*ypct(j)
           dflux_q(i) = dflux_q(i) + y_dflux_q(j)*ypct(j)
+#ifdef ISO
+        DO ixt=1,niso
+          xtsnow(ixt,i,nsrf) = yxtsnow(ixt,j)  
+        ENDDO
+        DO ixt=1,ntraciso
+          xtevap(ixt,i,nsrf) = - flux_xt(ixt,i,1,nsrf)
+          dflux_xt(ixt,i) = dflux_xt(ixt,i) + y_dflux_xt(ixt,j)*ypct(j)
+        ENDDO  
+        IF (nsrf == is_lic) THEN
+          DO ixt=1,niso
+            Rland_ice(ixt,i) = yRland_ice(ixt,j)  
+          ENDDO
+        ENDIF !IF (nsrf == is_lic) THEN     
+#ifdef ISOVERIF
+        IF (iso_eau.gt.0) THEN  
+          call iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, &
+     &         'pbl_surf_mod 1230',errmax,errmaxrel)
+        ENDIF !if (iso_eau.gt.0) then
+#endif        
+#endif
        ENDDO
 
@@ -2902 +3390 @@
              i = ni(j)
              qsol(i) = yqsol(j)
+#ifdef ISO
+             runoff_diag(i)=yrunoff_diag(j)   
+             DO ixt=1,niso
+               xtsol(ixt,i) = yxtsol(ixt,j)
+               xtrunoff_diag(ixt,i)=yxtrunoff_diag(ixt,j)
+             ENDDO
+#endif
           ENDDO
        ENDIF
@@ -2914 +3409 @@
           ENDDO
        ENDDO
-       
+
+#ifdef ISO
+#ifdef ISOVERIF
+       !write(*,*) 'pbl_surface 2858'
+       DO i = 1, klon
+         DO ixt=1,niso
+           call iso_verif_noNaN(xtsol(ixt,i),'pbl_surface 1405')
+         ENDDO
+       ENDDO
+#endif
+#ifdef ISOVERIF
+     IF (iso_eau.gt.0) THEN
+        call iso_verif_egalite_vect2D( &
+                y_d_xt,y_d_q, &
+                'pbl_surface_mod 1261',ntraciso,klon,klev)
+     ENDIF !if (iso_eau.gt.0) then
+#endif
+#endif
 !!! jyg le 07/02/2012
        IF (iflag_split .ge.1) THEN
@@ -2933 +3445 @@
            d_u_w(i,k) = d_u_w(i,k) + y_d_u_w(j,k)
            d_v_w(i,k) = d_v_w(i,k) + y_d_v_w(j,k)
+#ifdef ISO
+           DO ixt=1,ntraciso
+             d_xt_x(ixt,i,k) = d_xt_x(ixt,i,k) + y_d_xt_x(ixt,j,k)
+             d_xt_w(ixt,i,k) = d_xt_w(ixt,i,k) + y_d_xt_w(ixt,j,k)
+           ENDDO ! DO ixt=1,ntraciso
+#endif
+
 !
 !!           d_wake_dlt(i,k) = d_wake_dlt(i,k) + y_d_t_w(i,k)-y_d_t_x(i,k)
@@ -2948 +3467 @@
              d_t(i,k) = d_t(i,k) + y_d_t(j,k)
              d_q(i,k) = d_q(i,k) + y_d_q(j,k)
+#ifdef ISO
+             DO ixt=1,ntraciso
+               d_xt(ixt,i,k) = d_xt(ixt,i,k) + y_d_xt(ixt,j,k)
+             ENDDO !DO ixt=1,ntraciso
+#endif
              d_u(i,k) = d_u(i,k) + y_d_u(j,k)
              d_v(i,k) = d_v(i,k) + y_d_v(j,k)
@@ -2962 +3486 @@
          ENDDO
         ENDIF
+
+#ifdef ISO
+#ifdef ISOVERIF
+!        write(*,*) 'd_q,d_xt(iso_eau,554,19)=',d_q(554,19),d_xt(iso_eau,554,19)
+!        write(*,*) 'pbl_surface 2929: d_q,d_xt(iso_eau,2,1)=',d_q(2,1),d_xt(iso_eau,2,1)
+!        write(*,*) 'y_d_q,y_d_xt(iso_eau,2,1)=',y_d_q(2,1),y_d_xt(iso_eau,2,1)
+!        write(*,*) 'iso_eau.gt.0=',iso_eau.gt.0
+        call iso_verif_noNaN_vect2D( &
+     &           d_xt, &
+     &           'pbl_surface 1385',ntraciso,klon,klev)  
+     IF (iso_eau >= 0) THEN
+        call iso_verif_egalite_vect2D( &
+                y_d_xt,y_d_q, &
+                'pbl_surface_mod 2945',ntraciso,klon,klev)
+        call iso_verif_egalite_vect2D( &
+                d_xt,d_q, &
+                'pbl_surface_mod 1276',ntraciso,klon,klev)
+     ENDIF !IF (iso_eau >= 0) THEN
+#endif
+#endif
 
 !      print*,'Dans pbl OK4'
@@ -3349 +3893 @@
    iflag_split=iflag_split_ref
 
+#ifdef ISO
+#ifdef ISOVERIF
+!        write(*,*) 'pbl_surface tmp 3249: d_q,d_xt(iso_eau,2,1)=',d_q(2,1),d_xt(iso_eau,2,1)
+    IF (iso_eau >= 0) THEN
+        call iso_verif_egalite_vect2D( &
+                d_xt,d_q, &
+                'pbl_surface_mod 1276',ntraciso,klon,klev)
+    ENDIF !IF (iso_eau >= 0) THEN
+#endif
+#endif
+
 !****************************************************************************************
 ! 16) Calculate the mean value over all sub-surfaces for some variables
@@ -3370 +3925 @@
     zxfluxt_w(:,:) = 0.0 ; zxfluxq_w(:,:) = 0.0
     zxfluxu_w(:,:) = 0.0 ; zxfluxv_w(:,:) = 0.0
+#ifdef ISO
+      zxfluxxt(:,:,:) = 0.0 
+      zxfluxxt_x(:,:,:) = 0.0
+      zxfluxxt_w(:,:,:) = 0.0
+#endif
+
 
 !!! jyg le 07/02/2012
@@ -3388 +3949 @@
               zxfluxu_w(i,k) = zxfluxu_w(i,k) + flux_u_w(i,k,nsrf) * pctsrf(i,nsrf)
               zxfluxv_w(i,k) = zxfluxv_w(i,k) + flux_v_w(i,k,nsrf) * pctsrf(i,nsrf)
+#ifdef ISO
+              DO ixt=1,ntraciso
+                zxfluxxt_x(ixt,i,k) = zxfluxxt_x(ixt,i,k) + flux_xt_x(ixt,i,k,nsrf) * pctsrf(i,nsrf)
+                zxfluxxt_w(ixt,i,k) = zxfluxxt_w(ixt,i,k) + flux_xt_w(ixt,i,k,nsrf) * pctsrf(i,nsrf)
+              ENDDO ! DO ixt=1,ntraciso
+#endif
             ENDDO
           ENDDO
@@ -3407 +3974 @@
              zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf(i,nsrf)
              zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf(i,nsrf)
+#ifdef ISO
+             DO ixt=1,niso
+               zxfluxxt(ixt,i,k) = zxfluxxt(ixt,i,k) + flux_xt(ixt,i,k,nsrf) * pctsrf(i,nsrf)
+             ENDDO ! DO ixt=1,niso
+#endif
           ENDDO
        ENDDO
@@ -3431 +4003 @@
        END DO
     endif
+
+#ifdef ISO
+    DO i = 1, klon
+      DO ixt=1,ntraciso
+        zxxtevap(ixt,i)     = - zxfluxxt(ixt,i,1)
+      ENDDO
+    ENDDO
+#endif
 
 !!!
@@ -3606 +4186 @@
     zxqsurf(:) = 0.0
     zxsnow(:)  = 0.0
+#ifdef ISO
+    zxxtsnow(:,:)  = 0.0
+#endif
+
     DO nsrf = 1, nbsrf
        DO i = 1, klon
           zxqsurf(i) = zxqsurf(i) + MAX(qsurf(i,nsrf),0.0) * pctsrf(i,nsrf)
           zxsnow(i)  = zxsnow(i)  + snow(i,nsrf)  * pctsrf(i,nsrf)
+#ifdef ISO
+          DO ixt=1,niso
+            zxxtsnow(ixt,i)  = zxxtsnow(ixt,i)  + xtsnow(ixt,i,nsrf)  * pctsrf(i,nsrf)
+          ENDDO ! DO ixt=1,niso
+#endif
        ENDDO
     ENDDO
@@ -3621 +4210 @@
 !****************************************************************************************
 !
-  SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
+  SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst &
+#ifdef ISO
+       ,xtsnow_rst,Rland_ice_rst &
+#endif       
+       )
 
     USE indice_sol_mod
+#ifdef ISO
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,ridicule
+    USE isotopes_verif_mod, ONLY: errmax,errmaxrel
+#endif    
+#endif
 
     INCLUDE "dimsoil.h"
@@ -3633 +4232 @@
     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: qsurf_rst
     REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst
+#ifdef ISO
+    REAL, DIMENSION(niso,klon, nbsrf), INTENT(OUT)     :: xtsnow_rst
+    REAL, DIMENSION(niso,klon), INTENT(OUT)            :: Rland_ice_rst
+#endif
 
  
@@ -3643 +4246 @@
     qsurf_rst(:,:)    = qsurf(:,:)
     ftsoil_rst(:,:,:) = ftsoil(:,:,:)
+#ifdef ISO
+    xtsnow_rst(:,:,:)  = xtsnow(:,:,:) 
+    Rland_ice_rst(:,:) = Rland_ice(:,:)
+#endif
 
 !****************************************************************************************
@@ -3655 +4262 @@
     IF (ALLOCATED(ydTs0)) DEALLOCATE(ydTs0)
     IF (ALLOCATED(ydqs0)) DEALLOCATE(ydqs0)
+#ifdef ISO
+    IF (ALLOCATED(xtsnow)) DEALLOCATE(xtsnow)
+    IF (ALLOCATED(Rland_ice)) DEALLOCATE(Rland_ice)
+    IF (ALLOCATED(Roce)) DEALLOCATE(Roce)
+#endif
 
 !jyg<
@@ -3673 +4285 @@
   SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, &
        evap, z0m, z0h, agesno,                                  &
-       tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke)  
+       tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke &
+#ifdef ISO
+      ,xtevap  &
+#endif
+&      )  
     !albedo SB <<<
     ! Give default values where new fraction has appread
@@ -3702 +4318 @@
     REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT)        :: z0m,z0h
     REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: tke
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon,nbsrf), INTENT(INOUT)        :: xtevap
+#endif
 
 ! Local variables
@@ -3709 +4328 @@
     CHARACTER(len=20) :: modname = 'pbl_surface_newfrac'
     INTEGER, DIMENSION(nbsrf) :: nfois=0, mfois=0, pfois=0
+#ifdef ISO
+    INTEGER           :: ixt
+#endif
 !
 ! All at once !! 
@@ -3754 +4376 @@
                 u10m(i,nsrf)  = u10m(i,nsrf_comp1)
                 v10m(i,nsrf)  = v10m(i,nsrf_comp1)
+#ifdef ISO
+                DO ixt=1,ntraciso
+                  xtevap(ixt,i,nsrf) = xtevap(ixt,i,nsrf_comp1)       
+                ENDDO       
+#endif
                 IF (iflag_pbl > 1) THEN
                  tke(i,:,nsrf) = tke(i,:,nsrf_comp1)
@@ -3809 +4436 @@
                 u10m(i,nsrf)  = u10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
                 v10m(i,nsrf)  = v10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + v10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+#ifdef ISO
+                DO ixt=1,ntraciso
+                  xtevap(ixt,i,nsrf) = xtevap(ixt,i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) &
+                                     + xtevap(ixt,i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) 
+                ENDDO       
+#endif
                 IF (iflag_pbl > 1) THEN
                  tke(i,:,nsrf) = tke(i,:,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tke(i,:,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
@@ -3821 +4454 @@
              agesno(i,nsrf)   = 0.
              ftsoil(i,:,nsrf) = tsurf(i,nsrf)
+#ifdef ISO            
+             xtsnow(:,i,nsrf) = 0.
+#endif
           ELSE
              pfois(nsrf) = pfois(nsrf)+ 1

LMDZ6/branches/cirrus/libf/phylmd/phys_local_var_mod.F90

@@ -14 +14 @@
       REAL, SAVE, ALLOCATABLE :: ql_seri(:,:),qs_seri(:,:)
       !$OMP THREADPRIVATE(ql_seri,qs_seri)
+! SN 15/07/2024 ISO 4D
+      REAL, SAVE, ALLOCATABLE :: qx_seri(:,:,:)
+      !$OMP THREADPRIVATE(qx_seri)
+! SN
       REAL, SAVE, ALLOCATABLE :: qbs_seri(:,:)
       !$OMP THREADPRIVATE(qbs_seri)
@@ -24 +28 @@
       REAL, SAVE, ALLOCATABLE :: pbl_eps(:,:,:)
       !$OMP THREADPRIVATE(pbl_eps)
+      REAL, SAVE, ALLOCATABLE :: tke_shear(:,:,:), tke_buoy(:,:,:), tke_trans(:,:,:)
+      !$OMP THREADPRIVATE(tke_shear,tke_buoy,tke_trans)
       REAL, SAVE, ALLOCATABLE :: tr_seri(:,:,:)
       !$OMP THREADPRIVATE(tr_seri)
@@ -64 +70 @@
       REAL, SAVE, ALLOCATABLE :: d_t_eva(:,:),d_q_eva(:,:),d_ql_eva(:,:),d_qi_eva(:,:)
       !$OMP THREADPRIVATE(d_t_eva,d_q_eva,d_ql_eva,d_qi_eva)
+! SN 15/07/2024 ISO 4D
+      REAL, SAVE, ALLOCATABLE :: d_qx_eva(:,:,:)
+      !$OMP THREADPRIVATE(d_qx_eva)
+! SN
       REAL, SAVE, ALLOCATABLE :: d_t_lscst(:,:),d_q_lscst(:,:)
       !$OMP THREADPRIVATE(d_t_lscst,d_q_lscst)
@@ -84 +94 @@
       REAL, SAVE, ALLOCATABLE :: d_t_vdf_x(:,:), d_q_vdf_x(:,:)
       !$OMP THREADPRIVATE( d_t_vdf_x, d_q_vdf_x)
-      REAL, SAVE, ALLOCATABLE :: d_t_bs(:,:), d_q_bs(:,:), d_qbs_bs(:,:)
-      !$OMP THREADPRIVATE( d_t_bs,d_q_bs, d_qbs_bs)
+      REAL, SAVE, ALLOCATABLE :: d_t_bsss(:,:), d_q_bsss(:,:), d_qbs_bsss(:,:)
+      !$OMP THREADPRIVATE( d_t_bsss,d_q_bsss, d_qbs_bsss)
 !>nrlmd+jyg
       REAL, SAVE, ALLOCATABLE :: d_t_oro(:,:)
@@ -117 +127 @@
       REAL, SAVE, ALLOCATABLE :: d_q_ch4(:,:)
       !$OMP THREADPRIVATE(d_q_ch4)
+#ifdef ISO
+      REAL, SAVE, ALLOCATABLE :: xt_seri(:,:,:)
+      !$OMP THREADPRIVATE( xt_seri)
+      REAL, SAVE, ALLOCATABLE :: xtl_seri(:,:,:)
+      !$OMP THREADPRIVATE( xtl_seri)
+      REAL, SAVE, ALLOCATABLE :: xts_seri(:,:,:)
+      !$OMP THREADPRIVATE( xts_seri)
+      REAL, SAVE, ALLOCATABLE :: xtbs_seri(:,:,:)
+      !$OMP THREADPRIVATE( xtbs_seri)
+      REAL, SAVE, ALLOCATABLE :: d_xt_eva(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_eva)
+      REAL, SAVE, ALLOCATABLE :: d_xtl_eva(:,:,:)
+      !$OMP THREADPRIVATE( d_xtl_eva)
+      REAL, SAVE, ALLOCATABLE :: d_xti_eva(:,:,:)
+      !$OMP THREADPRIVATE( d_xti_eva)
+      REAL, SAVE, ALLOCATABLE :: d_xt_vdf(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_vdf)
+      REAL, SAVE, ALLOCATABLE :: d_xt_dyn(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_dyn)
+      REAL, SAVE, ALLOCATABLE :: d_xtl_dyn(:,:,:), d_xts_dyn(:,:,:), d_xtbs_dyn(:,:,:)
+      !$OMP THREADPRIVATE(d_xtl_dyn, d_xts_dyn, d_xtbs_dyn)
+      REAL, SAVE, ALLOCATABLE :: d_xt_con(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_con)
+      REAL, SAVE, ALLOCATABLE :: d_xt_wake(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_wake)
+      REAL, SAVE, ALLOCATABLE :: d_xt_lsc(:,:,:),d_xtl_lsc(:,:,:),d_xti_lsc(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_lsc,d_xtl_lsc,d_xti_lsc)
+      REAL, SAVE, ALLOCATABLE :: d_xt_ajsb(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_ajsb)
+      REAL, SAVE, ALLOCATABLE :: d_xt_ajs(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_ajs)
+      REAL, SAVE, ALLOCATABLE :: d_xt_ajs_w(:,:,:), d_xt_ajs_x(:,:,:)
+      !$OMP THREADPRIVATE(d_xt_ajs_w, d_xt_ajs_x)
+      REAL, SAVE, ALLOCATABLE :: d_xt_vdf_w(:,:,:), d_xt_vdf_x(:,:,:)
+      !$OMP THREADPRIVATE(d_xt_vdf_w, d_xt_vdf_x)
+      REAL, SAVE, ALLOCATABLE :: d_xt_ch4(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_ch4)
+      REAL, SAVE, ALLOCATABLE :: d_xt_prod_nucl(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_prod_nucl)
+      REAL, SAVE, ALLOCATABLE :: d_xt_cosmo(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_cosmo)
+      REAL, SAVE, ALLOCATABLE :: d_xt_decroiss(:,:,:)
+      !$OMP THREADPRIVATE( d_xt_decroiss)
+#endif
 
 ! tendance du a la conersion Ec -> E thermique
@@ -124 +178 @@
       !$OMP THREADPRIVATE(d_ts, d_tr)
 
-! aerosols
-      REAL, SAVE, ALLOCATABLE :: m_allaer (:,:,:)
-      !$OMP THREADPRIVATE(m_allaer)
 ! diagnostique pour le rayonnement
       REAL, SAVE, ALLOCATABLE :: topswad_aero(:),  solswad_aero(:)      ! diag
@@ -307 +358 @@
 !!!OMP THREADPRIVATE(d_s_the, d_dens_the)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)           :: d_deltat_ajs_cv, d_deltaq_ajs_cv
-!$OMP THREADPRIVATE(d_deltat_ajs_cv, d_deltaq_ajs_cv)                       
+!$OMP THREADPRIVATE(d_deltat_ajs_cv, d_deltaq_ajs_cv)
+#ifdef ISO
+    REAL, SAVE, ALLOCATABLE,DIMENSION(:,:,:)          :: d_deltaxt_wk
+!$OMP THREADPRIVATE(d_deltaxt_wk)
+    REAL, SAVE, ALLOCATABLE,DIMENSION(:,:,:)          :: d_deltaxt_wk_gw
+!$OMP THREADPRIVATE(d_deltaxt_wk_gw)
+    REAL, SAVE, ALLOCATABLE,DIMENSION(:,:,:)          ::  d_deltaxt_the
+!$OMP THREADPRIVATE(d_deltaxt_the)
+    REAL, SAVE, ALLOCATABLE,DIMENSION(:,:,:)          ::  d_deltaxt_vdf
+!$OMP THREADPRIVATE(d_deltaxt_vdf)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)           ::  d_deltaxt_ajs_cv
+!$OMP THREADPRIVATE(d_deltaxt_ajs_cv)
+#endif                       
 !!         End of Wake variables
 !!
@@ -343 +406 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfluxlat, zxtsol, snow_lsc, zxfqfonte
 !$OMP THREADPRIVATE(zxfluxlat, zxtsol, snow_lsc, zxfqfonte)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxrunofflic
-!$OMP THREADPRIVATE(zxrunofflic)
+!SN runoffdiag
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxrunofflic, runoff_diag
+!$OMP THREADPRIVATE(zxrunofflic, runoff_diag)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxqsurf, rain_lsc, rain_num
 !$OMP THREADPRIVATE(zxqsurf, rain_lsc, rain_num)
+#ifdef ISO
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: xtevap,xtprw
+!$OMP THREADPRIVATE(xtevap,xtprw)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: h1_diag
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: xtrunoff_diag
+!$OMP THREADPRIVATE(h1_diagv,xtrunoff_diag)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: zxfxtcalving
+!$OMP THREADPRIVATE(zxfxtcalving)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: xtsnow_lsc, zxfxtfonte
+!$OMP THREADPRIVATE(xtsnow_lsc, zxfxtfonte)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: zxxtrunofflic
+!$OMP THREADPRIVATE(zxxtrunofflic)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: xtrain_lsc
+!$OMP THREADPRIVATE(xtrain_lsc)
+#endif
 !
 !jyg+nrlmd<
@@ -384 +463 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: kh, kh_x, kh_w
 !$OMP THREADPRIVATE(kh, kh_x, kh_w)
+#ifdef ISO
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: dxtvdf_x, dxtvdf_w
+!$OMP THREADPRIVATE(dxtvdf_x, dxtvdf_w)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: xt_therm
+!$OMP THREADPRIVATE(xt_therm)
+#endif
 !!!
 !!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
@@ -446 +531 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:):: sij
 !$OMP THREADPRIVATE(sij)
+#ifdef ISO
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xtwdtrainA
+!$OMP THREADPRIVATE(xtwdtrainA)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xtev
+!$OMP THREADPRIVATE(xtev)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xttaa
+!$OMP THREADPRIVATE(xttaa)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xtclw
+!$OMP THREADPRIVATE(xtclw)
+#ifdef DIAGISO
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: qlp
+!$OMP THREADPRIVATE(qlp)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: qvp
+!$OMP THREADPRIVATE(qvp)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: fq_detrainement
+!$OMP THREADPRIVATE(fq_detrainement)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: fq_ddft
+!$OMP THREADPRIVATE(fq_ddft)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: fq_fluxmasse
+!$OMP THREADPRIVATE(fq_fluxmasse)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: fq_evapprecip
+!$OMP THREADPRIVATE(fq_evapprecip)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: f_detrainement
+!$OMP THREADPRIVATE(f_detrainement)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: q_detrainement
+!$OMP THREADPRIVATE(q_detrainement)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xt_detrainement
+!$OMP THREADPRIVATE(xt_detrainement)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xtlp
+!$OMP THREADPRIVATE(xtlp)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xtvp
+!$OMP THREADPRIVATE(xtvp)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: q_the
+!$OMP THREADPRIVATE(q_the)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: xt_the
+!$OMP THREADPRIVATE(xt_the)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: fxt_detrainement
+!$OMP THREADPRIVATE(fxt_detrainement)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: fxt_ddft
+!$OMP THREADPRIVATE(fxt_ddft)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: fxt_fluxmasse
+!$OMP THREADPRIVATE(fxt_fluxmasse)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: fxt_evapprecip
+!$OMP THREADPRIVATE(fxt_evapprecip)
+#endif
+#endif
 !
 !      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: coefh, coefm, lambda_th
@@ -481 +612 @@
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: pfraclr,pfracld
 !$OMP THREADPRIVATE(pfraclr,pfracld)
+      REAL, SAVE, ALLOCATABLE :: cldfraliq(:,:)
+!$OMP THREADPRIVATE(cldfraliq)
+      REAL, SAVE, ALLOCATABLE ::mean_icefracturb(:,:)
+!$OMP THREADPRIVATE(mean_icefracturb)
+      REAL, SAVE, ALLOCATABLE :: sigma2_icefracturb(:,:)
+!$OMP THREADPRIVATE(sigma2_icefracturb)
 
 ! variables de sorties MM
@@ -487 +624 @@
 !$OMP THREADPRIVATE(zxsnow,snowhgt,qsnow,to_ice)
 !$OMP THREADPRIVATE(sissnow,runoff,albsol3_lic)
+#ifdef ISO
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: zxxtsnow
+!$OMP THREADPRIVATE(zxxtsnow)     
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: xtVprecip,xtVprecipi
+!$OMP THREADPRIVATE(xtVprecip,xtVprecipi) 
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: pxtrfl, pxtsfl
+!$OMP THREADPRIVATE(pxtrfl, pxtsfl) 
+#endif
 
       REAL, ALLOCATABLE, SAVE, DIMENSION(:) :: p_tropopause, z_tropopause, t_tropopause
@@ -567 +712 @@
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: R2SO4
 !$OMP THREADPRIVATE(R2SO4)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: R2SO4B
+!$OMP THREADPRIVATE(R2SO4B)
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: DENSO4
 !$OMP THREADPRIVATE(DENSO4)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:, :) :: DENSO4B
+!$OMP THREADPRIVATE(DENSO4B)      
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: f_r_wet
 !$OMP THREADPRIVATE(f_r_wet)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:, :) :: f_r_wetB
+!$OMP THREADPRIVATE(f_r_wetB)
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: decfluxaer
 !$OMP THREADPRIVATE(decfluxaer)
@@ -599 +750 @@
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vsed_aer
 !$OMP THREADPRIVATE(vsed_aer)
+!     Sulfate aerosol concentration (dry mixing ratio) (condensed H2SO4 mmr)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sulfmmr
+!$OMP THREADPRIVATE(sulfmmr)
+!     SAD all aerosols (cm2/cm3)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: SAD_sulfate
+!$OMP THREADPRIVATE(SAD_sulfate)
+!     Effective radius of wet surface aerosols (cm)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: reff_sulfate
+!$OMP THREADPRIVATE(reff_sulfate)
+!     sulfate MMR in different modes (based on sulfmmr, it must be dry mmr)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sulfmmr_mode
+!$OMP THREADPRIVATE(sulfmmr_mode)
+!     particle concentration in different modes (part/m3)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nd_mode
+!$OMP THREADPRIVATE(nd_mode)
 !
 !---3D budget variables
@@ -647 +813 @@
 SUBROUTINE phys_local_var_init
 USE dimphy
-USE infotrac_phy, ONLY : nbtr
+USE infotrac_phy, ONLY : nbtr,nqtot
+#ifdef ISO
+USE infotrac_phy, ONLY : ntraciso=>ntiso,niso
+#endif
 USE aero_mod
 USE indice_sol_mod
 USE phys_output_var_mod
 USE phys_state_var_mod
+#ifdef CPP_StratAer
+USE infotrac_phy, ONLY : nbtr_bin
+#endif
 
 IMPLICIT NONE
       ALLOCATE(t_seri(klon,klev),q_seri(klon,klev),ql_seri(klon,klev),qs_seri(klon,klev), qbs_seri(klon,klev))
+! SN 4D ISO
+      ALLOCATE(qx_seri(klon,klev,nqtot))
+! SN
       ALLOCATE(u_seri(klon,klev),v_seri(klon,klev))
       ALLOCATE(cf_seri(klon,klev),rvc_seri(klon,klev))
       ALLOCATE(l_mixmin(klon,klev+1,nbsrf),l_mix(klon,klev+1,nbsrf),wprime(klon,klev+1,nbsrf))
       ALLOCATE(pbl_eps(klon,klev+1,nbsrf+1))
+      ALLOCATE(tke_shear(klon,klev+1,nbsrf), tke_buoy(klon,klev+1,nbsrf), tke_trans(klon,klev+1,nbsrf))
       pbl_eps(:,:,:)=0.
+      tke_shear(:,:,:)=0.; tke_buoy(:,:,:)=0.; tke_trans(:,:,:)=0.
       l_mix(:,:,:)=0.;l_mixmin(:,:,:)=0.;wprime(:,:,:)=0. ! doit etre initialse car pas toujours remplis
       ALLOCATE(rhcl(klon,klev))
@@ -684 +861 @@
       ALLOCATE(d_u_ajs(klon,klev),d_v_ajs(klon,klev))
       ALLOCATE(d_t_eva(klon,klev),d_q_eva(klon,klev))
+! SN 4D ISO
+      ALLOCATE(d_qx_eva(klon,klev,nqtot))
+! SN 
       ALLOCATE(d_ql_eva(klon,klev),d_qi_eva(klon,klev))
       ALLOCATE(d_t_lscst(klon,klev),d_q_lscst(klon,klev))
@@ -690 +870 @@
       ALLOCATE(d_t_vdf(klon,klev),d_q_vdf(klon,klev),d_t_diss(klon,klev))
       ALLOCATE (d_qbs_vdf(klon,klev))
-      ALLOCATE(d_t_bs(klon,klev),d_q_bs(klon,klev),d_qbs_bs(klon,klev))
+      ALLOCATE(d_t_bsss(klon,klev),d_q_bsss(klon,klev),d_qbs_bsss(klon,klev))
       ALLOCATE(d_t_vdf_w(klon,klev),d_q_vdf_w(klon,klev))
       ALLOCATE(d_t_vdf_x(klon,klev),d_q_vdf_x(klon,klev))
+#ifdef ISO
+      allocate(xt_seri(ntraciso,klon,klev))
+      allocate(xtl_seri(ntraciso,klon,klev))
+      allocate(xts_seri(ntraciso,klon,klev))
+      allocate(xtbs_seri(ntraciso,klon,klev))
+      allocate(d_xt_dyn(ntraciso,klon,klev))
+      allocate(d_xtl_dyn(ntraciso,klon,klev))
+      allocate(d_xts_dyn(ntraciso,klon,klev))
+      allocate(d_xtbs_dyn(ntraciso,klon,klev))
+      allocate(d_xt_con(ntraciso,klon,klev))
+      allocate(d_xt_wake(ntraciso,klon,klev))
+      allocate(d_xt_lsc(ntraciso,klon,klev))
+      allocate(d_xtl_lsc(ntraciso,klon,klev))
+      allocate(d_xti_lsc(ntraciso,klon,klev))
+      allocate(d_xt_ajsb(ntraciso,klon,klev))
+      allocate(d_xt_ajs(ntraciso,klon,klev))
+      allocate(d_xt_ajs_w(ntraciso,klon,klev))
+      allocate(d_xt_ajs_x(ntraciso,klon,klev))
+      allocate(d_xt_eva(ntraciso,klon,klev))
+      allocate(d_xtl_eva(ntraciso,klon,klev))
+      allocate(d_xti_eva(ntraciso,klon,klev))
+      allocate(d_xt_vdf(ntraciso,klon,klev))  
+      allocate(d_xt_vdf_w(ntraciso,klon,klev))
+      allocate(d_xt_vdf_x(ntraciso,klon,klev))
+      allocate(d_xt_ch4(ntraciso,klon,klev))
+      allocate(d_xt_prod_nucl(ntraciso,klon,klev))
+      allocate(d_xt_cosmo(ntraciso,klon,klev))
+      allocate(d_xt_decroiss(ntraciso,klon,klev))
+#endif
 
       ALLOCATE(d_u_vdf(klon,klev),d_v_vdf(klon,klev))
@@ -704 +913 @@
       ALLOCATE(d_ts(klon,nbsrf), d_tr(klon,klev,nbtr))
 
-! aerosols
-      ALLOCATE(m_allaer(klon,klev,naero_tot))
 ! Special RRTM
       ALLOCATE(ZLWFT0_i(klon,klev+1),ZSWFT0_i(klon,klev+1),ZFLDN0(klon,klev+1))
@@ -813 +1020 @@
 !!      ALLOCATE( d_s_the(klon), d_dens_the(klon))
       ALLOCATE(d_deltat_ajs_cv(klon, klev), d_deltaq_ajs_cv(klon, klev))
+#ifdef ISO
+      ALLOCATE(d_deltaxt_wk(ntraciso,klon, klev))
+      ALLOCATE(d_deltaxt_wk_gw(ntraciso,klon, klev))
+      ALLOCATE(d_deltaxt_the(ntraciso,klon, klev))
+      ALLOCATE(d_deltaxt_vdf(ntraciso,klon, klev))
+      ALLOCATE(d_deltaxt_ajs_cv(ntraciso,klon, klev))
+#endif
 !!         End of wake variables
 !!
@@ -834 +1048 @@
       ALLOCATE(zxfqcalving(klon), zxfluxlat(klon))
       ALLOCATE(zxtsol(klon), snow_lsc(klon), zxfqfonte(klon), zxqsurf(klon))
-      ALLOCATE(zxrunofflic(klon))
+! SN add runoff_diag
+      ALLOCATE(zxrunofflic(klon), runoff_diag(klon))
+      runoff_diag(:)=0.
       ALLOCATE(zxustartlic(klon), zxrhoslic(klon), zxqsaltlic(klon))
       zxustartlic(:)=0. ; zxrhoslic(:)=0. ; zxqsaltlic(:)=0.
@@ -841 +1057 @@
       ALLOCATE(qlth(klon,klev), qith(klon,klev), qsith(klon,klev), wiceth(klon,klev))
       !
+#ifdef ISO
+      ALLOCATE(xtevap(ntraciso,klon))
+      ALLOCATE(xtprw(ntraciso,klon))
+      ALLOCATE(zxfxtcalving(niso,klon))
+      ALLOCATE(xtsnow_lsc(ntraciso,klon), zxfxtfonte(niso,klon)) 
+      ALLOCATE(zxxtrunofflic(niso,klon)) 
+      ALLOCATE(xtrain_lsc(ntraciso,klon))
+      ALLOCATE(xtrunoff_diag(niso,klon))
+      ALLOCATE(h1_diag(klon))
+!SN
+      xtrunoff_diag(:,:)=0. ! because variables are only given values on knon grid points
+#endif
+!
       ALLOCATE(sens_x(klon), sens_w(klon))
       ALLOCATE(zxfluxlat_x(klon), zxfluxlat_w(klon))
@@ -857 +1086 @@
       ALLOCATE(cdragm_x(klon), cdragm_w(klon))
       ALLOCATE(kh(klon), kh_x(klon), kh_w(klon))
+#ifdef ISO
+      ALLOCATE(dxtvdf_x(ntraciso,klon,klev), dxtvdf_w(ntraciso,klon,klev))
+      ALLOCATE(xt_therm(ntraciso,klon,klev))
+#endif
 !
       ALLOCATE(ptconv(klon,klev))
@@ -912 +1145 @@
       ALLOCATE(epmlmMm(klon,klev,klev), eplaMm(klon,klev))
       ALLOCATE(sij(klon,klev,klev))
+#ifdef ISO
+      ALLOCATE(xtwdtrainA(ntraciso,klon,klev))
+      ALLOCATE(xtev(ntraciso,klon,klev) )
+      ALLOCATE(xttaa(ntraciso,klon,klev) )
+      ALLOCATE(xtclw(ntraciso,klon,klev) )
+#ifdef DIAGISO
+      ALLOCATE(qlp(klon,klev))
+      ALLOCATE(qvp(klon,klev))
+      ALLOCATE(fq_detrainement(klon,klev))
+      ALLOCATE(fq_ddft(klon,klev))
+      ALLOCATE(fq_fluxmasse(klon,klev))
+      ALLOCATE(fq_evapprecip(klon,klev))
+      ALLOCATE(f_detrainement(klon,klev), q_detrainement(klon,klev))
+      ALLOCATE(xtlp(ntraciso,klon,klev))
+      ALLOCATE(xtvp(ntraciso,klon,klev))
+      ALLOCATE(q_the(klon,klev), xt_the(ntraciso,klon,klev))
+      ALLOCATE(fxt_detrainement(ntraciso,klon,klev))
+      ALLOCATE(fxt_ddft(ntraciso,klon,klev))
+      ALLOCATE(fxt_fluxmasse(ntraciso,klon,klev))
+      ALLOCATE(fxt_evapprecip(ntraciso,klon,klev))
+      ALLOCATE(xt_detrainement(ntraciso,klon,klev))
+#endif
+#endif
 
       ALLOCATE(prfl(klon, klev+1))
@@ -931 +1187 @@
       ALLOCATE(pfraclr(klon,klev),pfracld(klon,klev))
       pfraclr(:,:)=0. ; pfracld(:,:)=0. ! because not always defined
+      ALLOCATE(cldfraliq(klon,klev))
+      ALLOCATE(sigma2_icefracturb(klon,klev))
+      ALLOCATE(mean_icefracturb(klon,klev))
       ALLOCATE(distcltop(klon,klev))
       ALLOCATE(temp_cltop(klon,klev))
@@ -937 +1196 @@
       ALLOCATE (zxsnow(klon),snowhgt(klon),qsnow(klon),to_ice(klon))
       ALLOCATE (sissnow(klon),runoff(klon),albsol3_lic(klon))
+#ifdef ISO
+      ALLOCATE (zxxtsnow(niso,klon))
+      ALLOCATE(xtVprecip(ntraciso,klon, klev+1),xtVprecipi(ntraciso,klon, klev+1))
+      ALLOCATE(pxtsfl(ntraciso,klon, klev+1),pxtrfl(ntraciso,klon, klev+1))
+#endif
 
       ALLOCATE (p_tropopause(klon))
@@ -968 +1232 @@
       ALLOCATE (d_q_emiss(klon,klev))
       ALLOCATE (R2SO4(klon,klev))
+      ALLOCATE (R2SO4B(klon,klev,nbtr_bin))
       ALLOCATE (DENSO4(klon,klev))
+      ALLOCATE (DENSO4B(klon,klev,nbtr_bin))
       ALLOCATE (f_r_wet(klon,klev))
+      ALLOCATE (f_r_wetB(klon,klev,nbtr_bin))
       ALLOCATE (decfluxaer(klon,nbtr))
       ALLOCATE (mdw(nbtr))
@@ -1006 +1273 @@
       ALLOCATE (surf_PM25_sulf(klon))
       ALLOCATE (vsed_aer(klon,klev))
+      ALLOCATE (sulfmmr(klon,klev))
+      ALLOCATE (SAD_sulfate(klon,klev))
+      ALLOCATE (reff_sulfate(klon,klev))
+      ALLOCATE (sulfmmr_mode(klon,klev,nbtr_bin))
+      ALLOCATE (nd_mode(klon,klev,nbtr_bin))
 #endif
 
@@ -1016 +1288 @@
 IMPLICIT NONE
       DEALLOCATE(t_seri,q_seri,ql_seri,qs_seri, qbs_seri)
+! SN 4D ISO
+      DEALLOCATE(qx_seri)
+! SN
       DEALLOCATE(u_seri,v_seri)
       DEALLOCATE(cf_seri,rvc_seri)
       DEALLOCATE(l_mixmin,l_mix,wprime)
+      DEALLOCATE(tke_shear,tke_buoy,tke_trans)
       DEALLOCATE(pbl_eps)
       DEALLOCATE(rhcl)
@@ -1043 +1319 @@
       DEALLOCATE(d_u_ajs,d_v_ajs)
       DEALLOCATE(d_t_eva,d_q_eva)
+! SN 4D ISO
+      DEALLOCATE(d_qx_eva)
+! SN
       DEALLOCATE(d_ql_eva,d_qi_eva)
       DEALLOCATE(d_t_lscst,d_q_lscst)
@@ -1049 +1328 @@
       DEALLOCATE(d_t_vdf,d_q_vdf,d_t_diss)
       DEALLOCATE(d_qbs_vdf)
-      DEALLOCATE(d_t_bs,d_q_bs,d_qbs_bs)
+      DEALLOCATE(d_t_bsss,d_q_bsss,d_qbs_bsss)
+#ifdef ISO
+      deallocate(xt_seri,xtl_seri,xts_seri,xtbs_seri)
+      DEALLOCATE(d_xtl_eva,d_xti_eva)
+      deallocate(d_xt_dyn,d_xtl_dyn,d_xts_dyn,d_xtbs_dyn)
+      deallocate(d_xt_con)
+      deallocate(d_xt_wake)
+      deallocate(d_xt_lsc)
+      deallocate(d_xtl_lsc,d_xti_lsc)
+      deallocate(d_xt_ajsb)
+      deallocate(d_xt_ajs)
+      deallocate(d_xt_ajs_w,d_xt_ajs_x)
+      deallocate(d_xt_eva)
+      deallocate(d_xtl_eva)
+      deallocate(d_xti_eva)
+      deallocate(d_xt_vdf)
+      deallocate(d_xt_vdf_w,d_xt_vdf_x)
+      deallocate(d_xt_ch4)
+      deallocate(d_xt_prod_nucl)
+      deallocate(d_xt_cosmo)
+      deallocate(d_xt_decroiss)
+#endif
+
       DEALLOCATE(d_u_vdf,d_v_vdf)
       DEALLOCATE(d_t_oli,d_t_oro)
@@ -1121 +1422 @@
       DEALLOCATE(solsw_aerop, solsw0_aerop)
       DEALLOCATE(topswcf_aerop, solswcf_aerop)
-!AI Aerosols
-      DEALLOCATE(m_allaer)
 !CK LW diagnostics
       DEALLOCATE(toplwad_aerop, sollwad_aerop)
@@ -1155 +1454 @@
 !!      DEALLOCATE( d_s_the, d_dens_the)
       DEALLOCATE(d_deltat_ajs_cv, d_deltaq_ajs_cv)
+#ifdef ISO
+      DEALLOCATE(d_deltaxt_wk)
+      DEALLOCATE(d_deltaxt_wk_gw)
+      DEALLOCATE(d_deltaxt_ajs_cv)
+      DEALLOCATE(d_deltaxt_vdf)
+#endif
 !
       DEALLOCATE(bils)
@@ -1173 +1478 @@
       DEALLOCATE(uwat, vwat)
       DEALLOCATE(zxfqcalving, zxfluxlat)
-      DEALLOCATE(zxrunofflic)
+! SN runoff_diag
+      DEALLOCATE(zxrunofflic, runoff_diag)
       DEALLOCATE(zxustartlic, zxrhoslic, zxqsaltlic)
       DEALLOCATE(zxtsol, snow_lsc, zxfqfonte, zxqsurf)
@@ -1194 +1500 @@
       DEALLOCATE(cdragm_x, cdragm_w)
       DEALLOCATE(kh, kh_x, kh_w)
+#ifdef ISO
+      DEALLOCATE(xtevap,xtprw)
+      DEALLOCATE(zxfxtcalving)
+      DEALLOCATE(zxxtrunofflic)
+      DEALLOCATE(xtsnow_lsc, zxfxtfonte)
+      DEALLOCATE(xtrain_lsc)
+      DEALLOCATE(dxtvdf_x, dxtvdf_w)
+      DEALLOCATE(xt_therm)
+      DEALLOCATE(h1_diag,xtrunoff_diag)
+#endif
 !
       DEALLOCATE(ptconv)
@@ -1243 +1559 @@
       DEALLOCATE(epmlmMm, eplaMm)
       DEALLOCATE(sij)
+#ifdef ISO
+      DEALLOCATE(xtwdtrainA)
+      DEALLOCATE(xttaa )
+      DEALLOCATE(xtclw )
+      DEALLOCATE(xtev )
+#ifdef DIAGISO
+      DEALLOCATE(qlp)
+      DEALLOCATE(qvp)
+      DEALLOCATE(fq_detrainement)
+      DEALLOCATE(fq_ddft)
+      DEALLOCATE(fq_fluxmasse)
+      DEALLOCATE(fq_evapprecip)
+      DEALLOCATE(f_detrainement,q_detrainement)
+      DEALLOCATE(xtlp)
+      DEALLOCATE(xtvp)
+      DEALLOCATE(q_the,xt_the)
+      DEALLOCATE(fxt_detrainement)
+      DEALLOCATE(fxt_ddft)
+      DEALLOCATE(fxt_fluxmasse)
+      DEALLOCATE(fxt_evapprecip)
+      DEALLOCATE(xt_detrainement)
+#endif
+#endif
 
 
@@ -1259 +1598 @@
       DEALLOCATE(rneb)
       DEALLOCATE(pfraclr,pfracld)
+      DEALLOCATE(cldfraliq)
+      DEALLOCATE(sigma2_icefracturb)
+      DEALLOCATE(mean_icefracturb)
       DEALLOCATE (zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic)
       DEALLOCATE(distcltop)
       DEALLOCATE(temp_cltop)
+#ifdef ISO
+      DEALLOCATE (zxxtsnow,xtVprecip,xtVprecipi,pxtrfl,pxtsfl)
+#endif
+
       DEALLOCATE (p_tropopause)
       DEALLOCATE (z_tropopause)
@@ -1291 +1637 @@
 ! variables for strat. aerosol CK
       DEALLOCATE (d_q_emiss)
-      DEALLOCATE (R2SO4)
-      DEALLOCATE (DENSO4)
-      DEALLOCATE (f_r_wet)
+      DEALLOCATE (R2SO4, R2SO4B)
+      DEALLOCATE (DENSO4, DENSO4B)
+      DEALLOCATE (f_r_wet, f_r_wetB)
       DEALLOCATE (decfluxaer)
       DEALLOCATE (mdw)
@@ -1308 +1654 @@
       DEALLOCATE (surf_PM25_sulf)
       DEALLOCATE (vsed_aer)
+      DEALLOCATE (sulfmmr)
+      DEALLOCATE (SAD_sulfate)
+      DEALLOCATE (reff_sulfate)
+      DEALLOCATE (sulfmmr_mode)
+      DEALLOCATE (nd_mode)
       DEALLOCATE (budg_3D_ocs_to_so2)
       DEALLOCATE (budg_3D_so2_to_h2so4)

LMDZ6/branches/cirrus/libf/phylmd/phys_output_ctrlout_mod.F90

@@ -1112 +1112 @@
   TYPE(ctrl_out), SAVE :: o_tke = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'tke ', 'TKE', 'm2/s2', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_tke_shear = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'tke_shear ', 'TKE shear term', 'm2/s3', (/ ('', i=1, 10) /))  
+  TYPE(ctrl_out), SAVE :: o_tke_buoy = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'tke_buoy ', 'TKE buoyancy term', 'm2/s3', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_tke_trans = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'tke_trans ', 'TKE transport term', 'm2/s3', (/ ('', i=1, 10) /))
   TYPE(ctrl_out), SAVE :: o_tke_dissip = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
-    'tke_dissip ', 'TKE DISSIPATION', 'm2/s3', (/ ('', i=1, 10) /))   
+    'tke_dissip ', 'TKE dissipation term', 'm2/s3', (/ ('', i=1, 10) /))
+
   TYPE(ctrl_out), SAVE :: o_tke_max = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'tke_max', 'TKE max', 'm2/s2',                                  &
@@ -1442 +1449 @@
   TYPE(ctrl_out), SAVE :: o_tau_strat_1020 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
     'OD1020_strat_only', 'Stratospheric Aerosol Optical depth at 1020 nm ', '1', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_SAD_sulfate = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
+    'SAD_sulfate', 'SAD WET sulfate aerosols', 'cm2/cm3', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_reff_sulfate = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
+    'reff_sulfate', 'Effective radius of WET sulfate aerosols', 'cm', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_sulfmmr = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
+    'sulfMMR', 'Sulfate aerosol concentration (dry mass mixing ratio)', 'kg(H2SO4)/kg(air)', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_nd_mode(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_sulfmmr_mode(:)
 !--chemistry
   TYPE(ctrl_out), SAVE :: o_R2SO4 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
@@ -1551 +1566 @@
   TYPE(ctrl_out), SAVE :: o_rneb = ctrl_out((/ 2, 5, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'rneb', 'Cloud fraction', '-', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_cldfraliq = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'cldfraliq', 'Liquid fraction of the cloud', '-', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_sigma2_icefracturb = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'sigma2_icefracturb', 'Variance of the diagnostic supersaturation distribution (icefrac_turb) [-]', '-', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_mean_icefracturb = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'mean_icefracturb', 'Mean of the diagnostic supersaturation distribution (icefrac_turb) [-]', '-', (/ ('', i=1, 10) /))
+ 
   TYPE(ctrl_out), SAVE :: o_rnebjn = ctrl_out((/ 2, 5, 10, 10, 10, 10, 11, 11,11, 11/), &      
     'rnebjn', 'Cloud fraction in day', '-', (/ ('', i=1, 10) /))
@@ -1981 +2003 @@
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dtr_dry(:)
 
+#ifdef ISO
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtprecip(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtevap(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtevap_srf(:,:) ! ajout Camille 8 mai 2023
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtplul(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtpluc(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtovap(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtoliq(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtcond(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtrunoff_diag(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtdyn(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtldyn(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtvdf(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtcon(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtlsc(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxteva(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtajs(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtthe(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtch4(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtprod_nucl(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtcosmo(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtdecroiss(:)
+#endif
+
   TYPE(ctrl_out), SAVE :: o_rsu = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'rsu', 'SW upward radiation', 'W m-2', (/ ('', i=1, 10) /))
@@ -2064 +2110 @@
   TYPE(ctrl_out), SAVE :: o_runoff = ctrl_out((/ 1, 1, 10, 1, 10, 10, 11, 11, 11, 11/), &
     'runoff', 'Run-off rate land ice', 'kg/m2/s', (/ ('', i=1, 10) /))
+! SN add runoff_diag
+!#ifdef ISO
+  TYPE(ctrl_out), SAVE :: o_runoff_diag = ctrl_out((/ 1, 1, 10, 1, 10, 10, 11, 11, 11, 11/), &
+    'runoffland', 'Run-off rate land for bucket', 'kg/m2/s', (/ ('', i=1, 10) /))
+!#endif
   TYPE(ctrl_out), SAVE :: o_albslw3 = ctrl_out((/ 1, 1, 1, 1, 10, 10, 11, 11, 11, 11/), &
     'albslw3', 'Surface albedo LW3', '-', (/ ('', i=1, 10) /))

LMDZ6/branches/cirrus/libf/phylmd/phys_output_mod.F90

@@ -35 +35 @@
     USE iophy 
     USE dimphy
-    USE infotrac_phy, ONLY: nqtot, tracers, niso
+    USE infotrac_phy, ONLY: nqtot, tracers, niso, ntraciso=>ntiso
     USE strings_mod,  ONLY: maxlen
     USE ioipsl
@@ -49 +49 @@
     ! ug Pour les sorties XIOS
     USE wxios
+#ifdef CPP_StratAer
+   USE infotrac_phy, ONLY: nbtr_bin
+#endif
+#ifdef ISO
+    USE isotopes_mod, ONLY: isoName,iso_HTO
+#ifdef ISOTRAC
+    use isotrac_mod, only: index_zone,index_iso,strtrac
+#endif
+#endif
 
     IMPLICIT NONE
@@ -93 +102 @@
     CHARACTER(LEN=4), DIMENSION(nlevSTD)  :: clevSTD
     REAL, DIMENSION(nlevSTD)              :: rlevSTD
-    INTEGER                               :: nsrf, k, iq, iff, i, j, ilev, itr, ixt, iiso, izone
+    INTEGER                               :: nsrf, k, iq, iff, i, j, ilev, itr, itrb, ixt, iiso, izone
     INTEGER                               :: naero
     LOGICAL                               :: ok_veget
@@ -112 +121 @@
     LOGICAL, DIMENSION(nfiles)            :: phys_out_filestations
 
+#ifdef ISO
+    CHARACTER(LEN=maxlen) :: outiso
+    CHARACTER(LEN=20) :: unit
+#endif
     CHARACTER(LEN=maxlen) :: tnam, lnam, dn
     INTEGER :: flag(nfiles)
@@ -158 +171 @@
     ALLOCATE(o_dtr_sscav(nqtot),o_dtr_sat(nqtot),o_dtr_uscav(nqtot))
     ALLOCATE(o_dtr_dry(nqtot),o_dtr_vdf(nqtot))
+#ifdef CPP_StratAer
+    ALLOCATE(o_nd_mode(nbtr_bin),o_sulfmmr_mode(nbtr_bin))
+#endif
+#ifdef ISO
+    ALLOCATE(o_xtprecip(ntraciso))
+    ALLOCATE(o_xtplul(ntraciso))
+    ALLOCATE(o_xtpluc(ntraciso))
+    ALLOCATE(o_xtevap(ntraciso))
+    ALLOCATE(o_xtevap_srf(ntraciso,4))
+    ALLOCATE(o_xtovap(ntraciso))
+    ALLOCATE(o_xtoliq(ntraciso))
+    ALLOCATE(o_xtcond(ntraciso))
+    ALLOCATE(o_xtrunoff_diag(ntraciso))
+    ALLOCATE(o_dxtdyn(ntraciso))
+    ALLOCATE(o_dxtldyn(ntraciso))
+    ALLOCATE(o_dxtcon(ntraciso))
+    ALLOCATE(o_dxtlsc(ntraciso))
+    ALLOCATE(o_dxteva(ntraciso))
+    ALLOCATE(o_dxtajs(ntraciso))
+    ALLOCATE(o_dxtvdf(ntraciso))
+    ALLOCATE(o_dxtthe(ntraciso))
+    ALLOCATE(o_dxtch4(ntraciso))
+    if (iso_HTO.gt.0) then
+      ALLOCATE(o_dxtprod_nucl(ntraciso))
+      ALLOCATE(o_dxtcosmo(ntraciso))
+      ALLOCATE(o_dxtdecroiss(ntraciso))
+    endif
+#endif
 
     levmax = [klev, klev, klev, klev, klev, klev, nlevSTD, nlevSTD, nlevSTD, klev]
@@ -467 +508 @@
      ENDIF ! clef_files
 
-          itr = 0
+          itr = 0; itrb = 0
           DO iq = 1, nqtot 
             IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
@@ -503 +544 @@
             lnam = 'Cumulated tracer '//TRIM(tracers(iq)%longName)
             tnam = 'cum'//TRIM(tracers(iq)%name); o_trac_cum(itr) = ctrl_out(flag, tnam, lnam, "-", [('',i=1,nfiles)])
-          ENDDO
+            
+#ifdef CPP_StratAer
+            if(tracers(iq)%name(1:3)=='BIN') then
+               itrb = itrb + 1
+               flag = [11, 11, 11, 11, 11, 11, 11, 11, 11, 1]
+               lnam = 'Dry particle concentration in '//TRIM(tracers(iq)%longName)
+               tnam = TRIM(tracers(iq)%name)//'_nd_mode';     o_nd_mode       (itrb) = ctrl_out(flag, tnam, lnam, "part/m3", [('',i=1,nfiles)])
+               lnam = 'Sulfate MMR in '//TRIM(tracers(iq)%longName)
+               tnam = TRIM(tracers(iq)%name)//'_sulfmmr_mode';o_sulfmmr_mode  (itrb) = ctrl_out(flag, tnam, lnam, "kg(H2SO4)/kg(air)", [('',i=1,nfiles)])
+            endif
+#endif
+         ENDDO
 
    ENDDO !  iff
 
-    ! Updated write frequencies due to phys_out_filetimesteps. 
+#ifdef ISO
+    write(*,*) 'phys_output_mid 589'
+    do ixt=1,ntraciso
+      outiso = TRIM(isoName(ixt))
+      i = INDEX(outiso, '_', .TRUE.)
+      outiso = outiso(1:i-1)//outiso(i+1:LEN_TRIM(outiso))
+
+      flag = [1,  1,  1, 10,  5, 10, 11, 11, 11, 11]; unit = 'kg/(s*m2)'
+      o_xtprecip(ixt)=ctrl_out(flag, 'precip'//TRIM(outiso), 'Precip Totale liq+sol', unit, [('',i=1,nfiles)])
+      o_xtpluc  (ixt)=ctrl_out(flag,   'pluc'//TRIM(outiso),    'Convective Precip.', unit, [('',i=1,nfiles)])
+
+      flag = [1,  1,  1, 10, 10, 10, 11, 11, 11, 11]
+      o_xtplul  (ixt)=ctrl_out(flag,   'plul'//TRIM(outiso),   'Large-scale Precip.', unit, [('',i=1,nfiles)])
+      o_xtevap  (ixt)=ctrl_out(flag,   'evap'//TRIM(outiso),             'Evaporat.', unit, [('',i=1,nfiles)])
+
+      ! ajout Camille 8 mai 2023
+      flag = [1, 6, 10, 10, 10, 10, 11, 11, 11, 11]
+      o_xtevap_srf (ixt,1)=ctrl_out(flag,   'evap_ter'//TRIM(outiso), 'Evap sfc'//clnsurf(1), unit, [('',i=1,nfiles)])
+      o_xtevap_srf (ixt,2)=ctrl_out(flag,   'evap_lic'//TRIM(outiso), 'Evap sfc'//clnsurf(2), unit, [('',i=1,nfiles)])
+      o_xtevap_srf (ixt,3)=ctrl_out(flag,   'evap_oce'//TRIM(outiso), 'Evap sfc'//clnsurf(3), unit, [('',i=1,nfiles)])
+      o_xtevap_srf (ixt,4)=ctrl_out(flag,   'evap_sic'//TRIM(outiso), 'Evap sfc'//clnsurf(4), unit, [('',i=1,nfiles)])
+
+      flag = [2,  3,  4, 10, 10, 10, 11, 11, 11, 11]; unit = 'kg/kg'
+      o_xtovap  (ixt)=ctrl_out(flag,   'ovap'//TRIM(outiso),     'Specific humidity', unit, [('',i=1,nfiles)])
+      o_xtoliq  (ixt)=ctrl_out(flag,   'oliq'//TRIM(outiso),          'Liquid water', unit, [('',i=1,nfiles)])
+      o_xtcond  (ixt)=ctrl_out(flag,  'ocond'//TRIM(outiso),       'Condensed water', unit, [('',i=1,nfiles)])
+
+      flag = [1,  1,  1, 10, 5, 10, 11, 11, 11, 11]; unit = 'kg/m2/s'
+      o_xtrunoff_diag  (ixt)=ctrl_out(flag, 'runoffland'//TRIM(outiso), 'Run-off rate land for bucket', unit, [('',i=1,nfiles)])
+
+      flag = [4, 10, 10, 10, 10, 10, 11, 11, 11, 11]; unit = '(kg/kg)/s'
+      o_dxtdyn  (ixt)=ctrl_out(flag,  'dqdyn'//TRIM(outiso),           'Dynamics dQ', unit, [('',i=1,nfiles)])
+      o_dxtldyn (ixt)=ctrl_out(flag, 'dqldyn'//TRIM(outiso),          'Dynamics dQL', unit, [('',i=1,nfiles)])
+      o_dxtcon  (ixt)=ctrl_out(flag,  'dqcon'//TRIM(outiso),         'Convection dQ', unit, [('',i=1,nfiles)])
+      o_dxteva  (ixt)=ctrl_out(flag,  'dqeva'//TRIM(outiso),      'Reevaporation dQ', unit, [('',i=1,nfiles)])
+      o_dxtlsc  (ixt)=ctrl_out(flag,  'dqlsc'//TRIM(outiso),       'Condensation dQ', unit, [('',i=1,nfiles)])
+      o_dxtajs  (ixt)=ctrl_out(flag,  'dqajs'//TRIM(outiso),        'Dry adjust. dQ', unit, [('',i=1,nfiles)])
+      o_dxtvdf  (ixt)=ctrl_out(flag,  'dqvdf'//TRIM(outiso),     'Boundary-layer dQ', unit, [('',i=1,nfiles)])
+      o_dxtthe  (ixt)=ctrl_out(flag,  'dqthe'//TRIM(outiso),            'Thermal dQ', unit, [('',i=1,nfiles)])
+
+      IF(ok_qch4) o_dxtch4(ixt)=ctrl_out(flag, 'dqch4'//TRIM(outiso), 'H2O due to CH4 oxidation & photolysis', &
+                                                                                      unit, [('',i=1,nfiles)])
+      IF(ixt == iso_HTO) THEN
+      o_dxtprod_nucl(ixt)=ctrl_out(flag, 'dqprodnucl'//TRIM(outiso), 'dHTO/dt due to nuclear production',      &
+                                                                                      unit, [('',i=1,nfiles)])
+      o_dxtcosmo    (ixt)=ctrl_out(flag,    'dqcosmo'//TRIM(outiso), 'dHTO/dt due to cosmogenic production',   &
+                                                                                      unit, [('',i=1,nfiles)])
+      o_dxtdecroiss (ixt)=ctrl_out(flag, 'dqdecroiss'//TRIM(outiso), 'dHTO/dt due to radiative destruction',   &
+                                                                                      unit, [('',i=1,nfiles)])
+      END IF
+    enddo !do ixt=1,niso
+    write(*,*) 'phys_output_mid 596'
+#endif
+
+   ! Updated write frequencies due to phys_out_filetimesteps. 
     ! Write frequencies are now in seconds.  
     ecrit_mth = ecrit_files(1)

LMDZ6/branches/cirrus/libf/phylmd/phys_output_write_mod.F90

@@ -65 +65 @@
          o_fder, o_ffonte, o_fqcalving, o_fqfonte, o_mrroli, o_runofflic, &
          o_taux, o_tauy, o_snowsrf, o_qsnow, &
-         o_snowhgt, o_toice, o_sissnow, o_runoff, &
+! SN runoff_diag
+         o_snowhgt, o_toice, o_sissnow, o_runoff, o_runoff_diag, &
          o_albslw3, o_pourc_srf, o_fract_srf, &
          o_taux_srf, o_tauy_srf, o_tsol_srf, &
@@ -141 +142 @@
          o_zfull, o_zhalf, o_rneb, o_rnebjn, o_rnebcon, &
          o_rnebls, o_rneblsvol, o_rhum, o_rhl, o_rhi, o_ozone, o_ozone_light, &
-         o_pfraclr, o_pfracld, &
+         o_pfraclr, o_pfracld, o_cldfraliq, o_sigma2_icefracturb, o_mean_icefracturb,  &
          o_qrainlsc, o_qsnowlsc, o_dqreva, o_dqrauto, o_dqrcol, o_dqrmelt, o_dqrfreez, &
          o_dqssub, o_dqsauto, o_dqsagg, o_dqsrim, o_dqsmelt, o_dqsfreez, &
@@ -147 +148 @@
          o_dqsphy, o_dqsphy2d, o_dqbsphy, o_dqbsphy2d, o_albe_srf, o_z0m_srf, o_z0h_srf, &
          o_ages_srf, o_snow_srf, o_alb1, o_alb2, o_tke, o_tke_dissip, &
-         o_tke_max, o_kz, o_kz_max, o_clwcon, &
+         o_tke_max, o_kz, o_kz_max, o_clwcon, o_tke_shear, o_tke_buoy, o_tke_trans,  &
          o_dtdyn, o_dqdyn, o_dqdyn2d, o_dqldyn, o_dqldyn2d, & 
          o_dqsdyn, o_dqsdyn2d, o_dqbsdyn, o_dqbsdyn2d, o_dudyn, o_dvdyn, &
@@ -208 +209 @@
 ! Isotopes
          o_xtprecip,o_xtplul,o_xtpluc,o_xtovap,o_xtoliq,o_xtcond, &
+         o_xtrunoff_diag, &
          o_xtevap,o_dxtdyn,o_dxtldyn,o_dxtcon,o_dxtlsc,o_dxteva, &
          o_dxtajs,o_dxtvdf,o_dxtthe, o_dxtch4, &
@@ -248 +250 @@
 
 #ifdef CPP_StratAer
+    USE infotrac_phy, ONLY: nbtr_bin
     USE phys_output_ctrlout_mod, ONLY:  & 
          o_budg_3D_nucl, o_budg_3D_cond_evap, o_budg_3D_ocs_to_so2, o_budg_3D_so2_to_h2so4, &
@@ -259 +262 @@
          o_budg_ocs_to_so2, o_budg_so2_to_h2so4, o_budg_h2so4_to_part, &
          o_surf_PM25_sulf, o_ext_strat_550, o_tau_strat_550, &
-         o_vsed_aer, o_tau_strat_1020, o_ext_strat_1020, o_f_r_wet
+         o_vsed_aer, o_tau_strat_1020, o_ext_strat_1020, o_f_r_wet, &
+         o_SAD_sulfate, o_reff_sulfate, o_sulfmmr, o_nd_mode, o_sulfmmr_mode
 #endif
 
@@ -314 +318 @@
          zn2mout, t2m_min_mon, t2m_max_mon, evap, &
          snowerosion, zxustartlic, zxrhoslic, zxqsaltlic, &
-         l_mixmin,l_mix, pbl_eps, &
+         l_mixmin,l_mix, pbl_eps, tke_shear, tke_buoy, tke_trans, &
          zu10m, zv10m, zq2m, zustar, zxqsurf, &
          rain_lsc, rain_num, snow_lsc, bils, sens, fder, &
          zxffonte, zxfqcalving, zxfqfonte, zxrunofflic, fluxu, &
          fluxv, zxsnow, qsnow, snowhgt, to_ice, &
-         sissnow, runoff, albsol3_lic, evap_pot, &
+! SN runoff_diag
+         sissnow, runoff, runoff_diag, albsol3_lic, evap_pot, &
          t2m, fluxt, fluxlat, fsollw, fsolsw, &
          wfbils, wfevap, &
@@ -367 +372 @@
          ql_seri, qs_seri, qbs_seri, tr_seri, qbs_seri,&
          zphi, u_seri, v_seri, omega, cldfra, &
-         rneb, rnebjn, rneblsvol, zx_rh, zx_rhl, zx_rhi, &
-         pfraclr, pfracld,  &
+         rneb, rnebjn, rneblsvol,  &
+         zx_rh, zx_rhl, zx_rhi, &
+         pfraclr, pfracld, cldfraliq, sigma2_icefracturb, mean_icefracturb, &
          qraindiag, qsnowdiag, dqreva, dqssub, &
          dqrauto,dqrcol,dqrmelt,dqrfreez, &
@@ -382 +388 @@
          d_t_lscst, d_q_lscth, d_q_lscst, plul_th, &
          plul_st, d_t_vdf, d_t_diss, d_q_vdf, d_q_eva, &
-         d_t_bs, d_q_bs, d_qbs_bs, d_qbs_vdf, &
+         d_t_bsss, d_q_bsss, d_qbs_bsss, d_qbs_vdf, &
          zw2, fraca, zmax_th, d_q_ajsb, d_t_ec, d_u_vdf, &
          d_v_vdf, d_u_oro, d_v_oro, d_t_oro, d_u_lif, &
@@ -395 +401 @@
         d_xt_ajs, d_xt_ajsb, &
         d_xt_prod_nucl,d_xt_cosmo,d_xt_decroiss, &
+        xtrunoff_diag, &
 #endif
          ep, epmax_diag, &  ! epmax_cape
@@ -416 +423 @@
          budg_ocs_to_so2, budg_so2_to_h2so4, budg_h2so4_to_part, & 
          surf_PM25_sulf, tau_strat_550, tausum_strat, &
-         vsed_aer, tau_strat_1020, f_r_wet
+         vsed_aer, tau_strat_1020, f_r_wet, &
+         SAD_sulfate, reff_sulfate, sulfmmr, nd_mode, sulfmmr_mode
 #endif
 
@@ -449 +457 @@
     USE indice_sol_mod, ONLY: nbsrf
 #ifdef ISO
-    USE isotopes_mod, ONLY: iso_HTO
+    USE isotopes_mod, ONLY: iso_HTO, isoName
 #endif
     USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg
@@ -530 +538 @@
     CHARACTER(LEN=maxlen) :: unt
 #endif
+
+#ifdef ISO
+    CHARACTER(LEN=maxlen) :: outiso
+#endif
+
     REAL,DIMENSION(klon,klev) :: z, dz
     REAL,DIMENSION(klon)      :: zrho, zt
@@ -1310 +1323 @@
 
        ENDDO
-       
-                
+
+
         IF (iflag_pbl > 1) THEN
           zx_tmp_fi3d=0.
@@ -1323 +1336 @@
           ENDIF
           
-          CALL histwrite_phy(o_tke_dissip, zx_tmp_fi3d)    
+          CALL histwrite_phy(o_tke_dissip, zx_tmp_fi3d)   
+
+          zx_tmp_fi3d=0.
+          IF (vars_defined) THEN
+             DO nsrf=1,nbsrf
+                DO k=1,klev
+                   zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k) &
+                        +pctsrf(:,nsrf)*tke_shear(:,k,nsrf)
+                ENDDO
+             ENDDO
+          ENDIF
+
+          CALL histwrite_phy(o_tke_shear, zx_tmp_fi3d)
+
+          zx_tmp_fi3d=0.
+          IF (vars_defined) THEN
+             DO nsrf=1,nbsrf
+                DO k=1,klev
+                   zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k) &
+                        +pctsrf(:,nsrf)*tke_buoy(:,k,nsrf)
+                ENDDO
+             ENDDO
+          ENDIF
+
+          CALL histwrite_phy(o_tke_buoy, zx_tmp_fi3d)
+
+
+          zx_tmp_fi3d=0.
+          IF (vars_defined) THEN
+             DO nsrf=1,nbsrf
+                DO k=1,klev
+                   zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k) &
+                        +pctsrf(:,nsrf)*tke_trans(:,k,nsrf)
+                ENDDO
+             ENDDO
+          ENDIF
+
+          CALL histwrite_phy(o_tke_trans, zx_tmp_fi3d)
+
        ENDIF
 
@@ -1814 +1865 @@
           CALL histwrite_phy(o_tau_strat_550, tausum_strat(:,1))
           CALL histwrite_phy(o_tau_strat_1020, tausum_strat(:,2))
+          CALL histwrite_phy(o_SAD_sulfate, SAD_sulfate)
+          CALL histwrite_phy(o_reff_sulfate, reff_sulfate)
+          CALL histwrite_phy(o_sulfmmr, sulfmmr)
+          ! All BINs fields
+          DO itr = 1, nbtr_bin
+             CALL histwrite_phy(o_nd_mode(itr), nd_mode(:,:,itr))
+             CALL histwrite_phy(o_sulfmmr_mode(itr), sulfmmr_mode(:,:,itr))
+          ENDDO !--itr
        ENDIF
 #endif
@@ -2005 +2064 @@
            CALL histwrite_phy(o_pfraclr, pfraclr)
            CALL histwrite_phy(o_pfracld, pfracld)
+           CALL histwrite_phy(o_cldfraliq, cldfraliq)
+           CALL histwrite_phy(o_sigma2_icefracturb, sigma2_icefracturb)
+           CALL histwrite_phy(o_mean_icefracturb, mean_icefracturb)
            IF (ok_poprecip) THEN
            CALL histwrite_phy(o_qrainlsc, qraindiag)
@@ -2306 +2368 @@
           IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_qbs_vdf(1:klon,1:klev)/pdtphys
           CALL histwrite_phy(o_dqbsvdf, zx_tmp_fi3d)
-          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_qbs_bs(1:klon,1:klev)/pdtphys
+          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_qbs_bsss(1:klon,1:klev)/pdtphys
           CALL histwrite_phy(o_dqbsbs, zx_tmp_fi3d)
-          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_bs(1:klon,1:klev)/pdtphys
+          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_bsss(1:klon,1:klev)/pdtphys
           CALL histwrite_phy(o_dqbs, zx_tmp_fi3d)
-          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_bs(1:klon,1:klev)/pdtphys
+          IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_bsss(1:klon,1:klev)/pdtphys
           CALL histwrite_phy(o_dtbs, zx_tmp_fi3d)
        ENDIF
@@ -2810 +2872 @@
        end if
 
+    !! runoff land bucket - ajout S. Nguyen 23 07 2024
+    CALL histwrite_phy(o_runoff_diag, runoff_diag)
+
 #ifdef ISO
-    do ixt=1,ntiso
-!        write(*,*) 'ixt'
+    !write(*,*) 'tmp phys_output_write: ntiso=',ntiso
+
+    DO ixt = 1, ntiso
+        !write(*,*) 'ixt,o_xtovap(ixt)=',ixt,o_xtovap(ixt)
         IF (vars_defined) zx_tmp_fi2d(:) = xtrain_fall(ixt,:) + xtsnow_fall(ixt,:)
         CALL histwrite_phy(o_xtprecip(ixt), zx_tmp_fi2d)
@@ -2824 +2891 @@
         CALL histwrite_phy(o_xtovap(ixt),  xt_seri(ixt,:,:))
         CALL histwrite_phy(o_xtoliq(ixt), xtl_seri(ixt,:,:))
+
+        !! runoff land bucket - ajout S. Nguyen 25 avril 2024
+        CALL histwrite_phy(o_xtrunoff_diag(ixt), xtrunoff_diag(ixt,:))
+
 
         DO nsrf = 1, nbsrf ! ajout Camille 8 mai 2023
@@ -2884 +2955 @@
           ENDDO !  iff
 #endif
+
+!SN activate water isotopes present in tracer.def
+#ifdef ISO
+          DO ixt = 1, ntiso
+            outiso = TRIM(isoName(ixt))
+            i = INDEX(outiso, '_', .TRUE.)
+            outiso = outiso(1:i-1)//outiso(i+1:LEN_TRIM(outiso))
+
+            CALL xios_set_fieldgroup_attr("iso2D_"//TRIM(outiso), enabled=.TRUE.)
+            CALL xios_set_fieldgroup_attr("iso3D_"//TRIM(outiso), enabled=.TRUE.)
+
+          ENDDO
+#endif
           !On finalise l'initialisation:
           IF (using_xios) CALL wxios_closedef()

LMDZ6/branches/cirrus/libf/phylmd/phys_state_var_mod.F90

@@ -87 +87 @@
 !$OMP THREADPRIVATE(prw_ancien, prlw_ancien, prsw_ancien, prbsw_ancien)
 #ifdef ISO
-      REAL, ALLOCATABLE, SAVE :: xt_ancien(:,:,:),xtl_ancien(:,:,:),xts_ancien(:,:,:)
-!$OMP THREADPRIVATE(xt_ancien,xtl_ancien,xts_ancien)
+      REAL, ALLOCATABLE, SAVE :: xt_ancien(:,:,:),xtl_ancien(:,:,:),xts_ancien(:,:,:), &
+              xtbs_ancien(:,:,:)
+!$OMP THREADPRIVATE(xt_ancien,xtl_ancien,xts_ancien,xtbs_ancien)
 #endif
       REAL, ALLOCATABLE, SAVE :: u_ancien(:,:), v_ancien(:,:)
@@ -760 +761 @@
       ALLOCATE(xtl_ancien(ntraciso,klon,klev))
       ALLOCATE(xts_ancien(ntraciso,klon,klev))
+      ALLOCATE(xtbs_ancien(ntraciso,klon,klev))
       ALLOCATE(xtrain_fall(ntraciso,klon))
       ALLOCATE(xtsnow_fall(ntraciso,klon))
@@ -950 +952 @@
 #ifdef ISO    
       DEALLOCATE(xtsol,fxtevap)  
-      DEALLOCATE(xt_ancien,xtl_ancien,xts_ancien, fxtd, wake_deltaxt)
+      DEALLOCATE(xt_ancien,xtl_ancien,xts_ancien,xtbs_ancien, fxtd, wake_deltaxt)
       DEALLOCATE(xtrain_fall, xtsnow_fall, xtrain_con, xtsnow_con)
 #ifdef ISOTRAC 

LMDZ6/branches/cirrus/libf/phylmd/physiq_mod.F90

@@ -1 @@
-!
+
 ! $Id$
 !
@@ -184 +184 @@
        d_ts, &
        !
-       d_t_bs,d_q_bs,d_qbs_bs, &
+       d_t_bsss,d_q_bsss,d_qbs_bsss, &
        !
 !       d_t_oli,d_u_oli,d_v_oli, &
@@ -333 +333 @@
        !
        rneblsvol, &
-       pfraclr,pfracld, &
-       distcltop,temp_cltop, &
+       pfraclr, pfracld, cldfraliq, sigma2_icefracturb, mean_icefracturb,  &
+       distcltop, temp_cltop,  &
        !-- LSCP - condensation and ice supersaturation variables
        qsub, qissr, qcld, subfra, issrfra, gamma_cond, ratio_qi_qtot, &
@@ -909 +909 @@
     REAL zdtime, zdtime1, zdtime2, zlongi
     !
-    REAL qcheck
     REAL z_avant(klon), z_apres(klon), z_factor(klon)
     LOGICAL zx_ajustq
@@ -1133 +1132 @@
     REAL, DIMENSION(klon,klev)     :: mass_solu_aero_pi
     ! - " - (pre-industrial value)
+    REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer
 
     ! Parameters
@@ -1271 +1271 @@
 
     !--OB variables for mass fixer (hard coded for now)
-    LOGICAL, PARAMETER :: mass_fixer=.FALSE.
     REAL qql1(klon),qql2(klon),corrqql
 
@@ -1401 +1400 @@
        IF (read_climoz>=1 .AND. create_etat0_limit .AND. grid_type==unstructured) & 
           CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
-
-#ifdef REPROBUS
-       CALL strataer_init
-       CALL strataer_emiss_init
-#endif
-
-#ifdef CPP_StratAer
-       CALL strataer_init
-       CALL strataer_nuc_init
-       CALL strataer_emiss_init
-#endif
 
        print*, '================================================='
@@ -1527 +1515 @@
        iflag_phytrac = 1 ! by default we do want to call phytrac
        CALL getin_p('iflag_phytrac',iflag_phytrac)
+
+       ok_water_mass_fixer=.FALSE.  ! OB: by default we do not apply the mass fixer
+       CALL getin_p('ok_water_mass_fixer',ok_water_mass_fixer)
 #ifdef CPP_Dust
        IF (iflag_phytrac.EQ.0) THEN 
@@ -1551 +1542 @@
        WRITE(lunout,*) 'fl_cor_ebil=',        fl_cor_ebil
        WRITE(lunout,*) 'iflag_phytrac=',      iflag_phytrac
+       WRITE(lunout,*) 'ok_water_mass_fixer=',ok_water_mass_fixer
        WRITE(lunout,*) 'NVM=',                nvm_lmdz
 
@@ -1802 +1794 @@
       IF (.NOT. create_etat0_limit) CALL init_readaerosolstrato(flag_aerosol_strat)  !! initialise aero strato from file for XIOS interpolation (unstructured_grid)
 
+      ! A.I : Initialisations pour le 1er passage a Cosp
       if (ok_cosp) then
+
 #ifdef CPP_COSP
-        ! A.I : Initialisations pour le 1er passage a Cosp
         CALL ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
                zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
@@ -1824 +1817 @@
 #endif
 
-#ifdef CPP_COSP2
-        CALL ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
+#ifdef CPP_COSPV2
+          CALL ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
                zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
                fiwc_cosp0,prfl_cosp0,psfl_cosp0,pmflxr_cosp0,pmflxs_cosp0, &
                mr_ozone_cosp0,cldtau_cosp0,cldemi_cosp0,JrNt_cosp0)
-     
-        CALL phys_cosp2(itap,phys_tstep,freq_cosp, &
-               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
-               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
-               klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
-               JrNt,ref_liq,ref_ice, &
-               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
-               zu10m,zv10m,pphis, &
-               zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
-               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
-               prfl(:,1:klev),psfl(:,1:klev), &
-               pmflxr(:,1:klev),pmflxs(:,1:klev), &
-               mr_ozone,cldtau, cldemi)
-#endif
-
-#ifdef CPP_COSPV2
+
           CALL lmdz_cosp_interface(itap,phys_tstep,freq_cosp, &
                ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
                ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
                klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
-               JrNt,ref_liq,ref_ice, &
-               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
-               zu10m,zv10m,pphis, &
-               phicosp,paprs(:,1:klev),pplay,zxtsol,t_seri, &
-               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
-               prfl(:,1:klev),psfl(:,1:klev), &
-               pmflxr(:,1:klev),pmflxs(:,1:klev), &
-               mr_ozone,cldtau, cldemi)
+               JrNt_cosp0,ref_liq_cosp0,ref_ice_cosp0, &
+               pctsrf_cosp0, &
+               zu10m_cosp0,zv10m_cosp0,pphis, &
+               pphi,paprs(:,1:klev),pplay,zxtsol_cosp0,t, &
+               qx(:,:,ivap),zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0,fiwc_cosp0, &
+               prfl_cosp0(:,1:klev),psfl_cosp0(:,1:klev), &
+               pmflxr_cosp0(:,1:klev),pmflxs_cosp0(:,1:klev), &
+               mr_ozone_cosp0,cldtau_cosp0, cldemi_cosp0)
 #endif
-      ENDIF 
+      endif  ! ok_cosp
 
        !
@@ -1908 +1886 @@
        !
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#ifdef REPROBUS
+       CALL strataer_init
+       CALL strataer_emiss_init
+#endif
+
+#ifdef CPP_StratAer
+       CALL strataer_init
+       CALL strataer_nuc_init
+       CALL strataer_emiss_init
+#endif
 
 #ifdef CPP_Dust
@@ -1948 +1936 @@
        ELSE IF (klon_glo==1) THEN
           pbl_tke(:,:,is_ave) = 0.
+          pbl_eps(:,:,is_ave) = 0.
           DO nsrf=1,nbsrf
             DO k = 1,klev+1
                  pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) &
                      +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+                 pbl_eps(:,k,is_ave) = pbl_eps(:,k,is_ave) &
+                     +pctsrf(:,nsrf)*pbl_eps(:,k,nsrf)
             ENDDO
           ENDDO
@@ -1957 +1948 @@
           pbl_tke(:,:,is_ave) = 0. !ym missing init : maybe must be initialized in the same way that for klon_glo==1 ??
 !>jyg
+          pbl_eps(:,:,is_ave) = 0.
        ENDIF
        !IM begin
@@ -2470 +2462 @@
     ENDDO
     !
-    !--OB mass fixer 
-    IF (mass_fixer) THEN
+    !--OB water mass fixer 
+    IF (ok_water_mass_fixer) THEN
     !--store initial water burden
     qql1(:)=0.0
@@ -3024 +3016 @@
     ! Blowing snow sublimation and sedimentation
 
-    d_t_bs(:,:)=0.
-    d_q_bs(:,:)=0.
-    d_qbs_bs(:,:)=0.
+    d_t_bsss(:,:)=0.
+    d_q_bsss(:,:)=0.
+    d_qbs_bsss(:,:)=0.
     bsfl(:,:)=0.
     bs_fall(:)=0.
@@ -3032 +3024 @@
 
      CALL call_blowing_snow_sublim_sedim(klon,klev,phys_tstep,t_seri,q_seri,qbs_seri,pplay,paprs, &
-                                        d_t_bs,d_q_bs,d_qbs_bs,bsfl,bs_fall)
+                                        d_t_bsss,d_q_bsss,d_qbs_bsss,bsfl,bs_fall)
 
      CALL add_phys_tend &
-               (du0,dv0,d_t_bs,d_q_bs,dql0,dqi0,d_qbs_bs,paprs,&
-               'bs',abortphy,flag_inhib_tend,itap,0)
+               (du0,dv0,d_t_bsss,d_q_bsss,dql0,dqi0,d_qbs_bsss,paprs,&
+               'bsss',abortphy,flag_inhib_tend,itap,0)
 
     ENDIF
@@ -3079 +3071 @@
        ENDDO
     ENDDO
-    IF (check) THEN
-       za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
-       WRITE(lunout,*) "avantcon=", za
-    ENDIF
-    zx_ajustq = .FALSE.
-    IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
-    IF (zx_ajustq) THEN
-       DO i = 1, klon
-          z_avant(i) = 0.0
-       ENDDO
-       DO k = 1, klev
-          DO i = 1, klon
-             z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) &
-                  *(paprs(i,k)-paprs(i,k+1))/RG
-          ENDDO
-       ENDDO
-    ENDIF
 
     ! Calcule de vitesse verticale a partir de flux de masse verticale
@@ -3488 +3463 @@
        CALL writefield_phy('q_seri',q_seri,nbp_lev)
     ENDIF
-
-    IF (check) THEN
-       za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
-       WRITE(lunout,*)"aprescon=", za
-       zx_t = 0.0
-       za = 0.0
-       DO i = 1, klon
-          za = za + cell_area(i)/REAL(klon)
-          zx_t = zx_t + (rain_con(i)+ &
-               snow_con(i))*cell_area(i)/REAL(klon)
-       ENDDO
-       zx_t = zx_t/za*phys_tstep
-       WRITE(lunout,*)"Precip=", zx_t
-    ENDIF
-    IF (zx_ajustq) THEN
-       DO i = 1, klon
-          z_apres(i) = 0.0
-       ENDDO
-       DO k = 1, klev
-          DO i = 1, klon
-             z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) &
-                  *(paprs(i,k)-paprs(i,k+1))/RG
-          ENDDO
-       ENDDO
-       DO i = 1, klon
-          z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*phys_tstep) &
-               /z_apres(i)
-       ENDDO
-       DO k = 1, klev
-          DO i = 1, klon
-             IF (z_factor(i).GT.(1.0+1.0E-08) .OR. &
-                  z_factor(i).LT.(1.0-1.0E-08)) THEN
-                q_seri(i,k) = q_seri(i,k) * z_factor(i)
-             ENDIF
-          ENDDO
-       ENDDO
-    ENDIF
-    zx_ajustq=.FALSE.
 
     !
@@ -3921 +3858 @@
 
     CALL lscp(klon,klev,phys_tstep,missing_val,paprs,pplay, &
-         t_seri, q_seri,ptconv,ratqs, &
+         t_seri, q_seri,qs_ancien,ptconv,ratqs, &
          d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, rneblsvol, & 
-         pfraclr,pfracld, &
+         pfraclr, pfracld, cldfraliq, sigma2_icefracturb, mean_icefracturb,  &
          radocond, picefra, rain_lsc, snow_lsc, &
          frac_impa, frac_nucl, beta_prec_fisrt, &
          prfl, psfl, rhcl,  &
          zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, &
-         iflag_ice_thermo, distcltop, temp_cltop, cell_area, &
-         cf_seri, rvc_seri, u_seri, v_seri, pbl_eps(:,:,is_ave), &
+         iflag_ice_thermo, distcltop, temp_cltop,   &
+         pbl_tke(:,:,is_ave), pbl_eps(:,:,is_ave), &
+         cell_area, &
+         cf_seri, rvc_seri, u_seri, v_seri, &
          qsub, qissr, qcld, subfra, issrfra, gamma_cond, ratio_qi_qtot, &
          dcf_sub, dcf_con, dcf_mix, dqi_adj, dqi_sub, dqi_con, dqi_mix, &
@@ -4021 +3960 @@
        ENDIF
 
-    ENDIF
-
-    IF (check) THEN
-       za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
-       WRITE(lunout,*)"apresilp=", za
-       zx_t = 0.0
-       za = 0.0
-       DO i = 1, klon
-          za = za + cell_area(i)/REAL(klon)
-          zx_t = zx_t + (rain_lsc(i) &
-               + snow_lsc(i))*cell_area(i)/REAL(klon)
-       ENDDO
-       zx_t = zx_t/za*phys_tstep
-       WRITE(lunout,*)"Precip=", zx_t
     ENDIF
 
@@ -4405 +4330 @@
                   flag_aerosol, flag_bc_internal_mixture, itap, jD_cur-jD_ref, &
                   pdtphys, pplay, paprs, t_seri, rhcl, presnivs,  &
-                  tr_seri, mass_solu_aero, mass_solu_aero_pi)  
+                  tr_seri, mass_solu_aero, mass_solu_aero_pi, m_allaer)  
 #else
                 abort_message='You should compile with -rad ecrad if running with iflag_rrtm=2'
@@ -4651 +4576 @@
                ! Rajoute par OB pour RRTM
                tau_aero_lw_rrtm, & 
-               cldtaupirad, &
+               cldtaupirad, m_allaer, &
 !              zqsat, flwcrad, fiwcrad, &
                zqsat, flwc, fiwc, &
@@ -4729 +4654 @@
                                 ! Rajoute par OB pour RRTM
                      tau_aero_lw_rrtm, &
-                     cldtaupi, &
+                     cldtaupi, m_allaer, &
 !                    zqsat, flwcrad, fiwcrad, &
                      zqsat, flwc, fiwc, &
@@ -4775 +4700 @@
                      tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
                      tau_aero_lw_rrtm, &
-                     cldtaupi, &
+                     cldtaupi, m_allaer, &
                      zqsat, flwc, fiwc, &
                      ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
@@ -5508 +5433 @@
     !--currently flag is turned off
     !==================================================================
-    IF (mass_fixer) THEN
+    IF (ok_water_mass_fixer) THEN
     qql2(:)=0.0
     DO k = 1, klev

LMDZ6/branches/cirrus/libf/phylmd/phystokenc_mod.F90

@@ -46 +46 @@
 ! Objet: Ecriture des variables pour transport offline
 !
+!  Note (A Cozic - July 2024): when coupled with inca, offline fields are no 
+!  longer calculated in this routine but directly in the physics code.
 !======================================================================
 

LMDZ6/branches/cirrus/libf/phylmd/radlwsw_m.F90

@@ -21 +21 @@
        tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm,& ! rajoute par OB RRTM
        tau_aero_lw_rrtm, &              ! rajoute par C.Kleinschmitt pour RRTM
-       cldtaupi, &
+       cldtaupi, m_allaer, &
        qsat, flwc, fiwc, &
        ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
@@ -80 +80 @@
     ! Besoin pour ECRAD de pctsrf, zmasq, longitude, altitude
 #ifdef CPP_ECRAD
-    USE phys_local_var_mod, ONLY: rhcl, m_allaer
     USE geometry_mod, ONLY: latitude, longitude
     USE phys_state_var_mod, ONLY: pctsrf
@@ -247 +246 @@
     REAL,    INTENT(in)  :: ref_liq_pi(klon,klev) ! cloud droplet radius pre-industrial from newmicro
     REAL,    INTENT(in)  :: ref_ice_pi(klon,klev) ! ice crystal radius   pre-industrial from newmicro
+    REAL,    INTENT(in)  :: m_allaer(klon,klev,naero_tot) ! mass aero
 
     CHARACTER(len=512), INTENT(in) :: namelist_ecrad_file
@@ -706 +706 @@
              zsollw0(i)=0.
              zsollwdown(i)=0.
+             ztoplwad0aero(i) = 0.
+             ztoplwadaero(i) = 0.
           ENDDO
           ! Old radiation scheme, used for AR4 runs

LMDZ6/branches/cirrus/libf/phylmd/surf_land_bucket_mod.F90

@@ -16 +16 @@
        snow, qsol, agesno, tsoil, &
        qsurf, z0_new, alb1_new, alb2_new, evap, &
-       fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+       fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l &
+#ifdef ISO
+       ,xtprecip_rain, xtprecip_snow,xtspechum, &
+       xtsnow, xtsol,xtevap,h1, &
+       runoff_diag,xtrunoff_diag,Rland_ice &
+#endif           
+            )
 
     USE limit_read_mod
@@ -28 +34 @@
     USE mod_phys_lmdz_para
     USE indice_sol_mod
+#ifdef ISO
+    use infotrac_phy, ONLY: ntiso,niso
+    USE isotopes_mod, ONLY: iso_eau, iso_HDO, iso_O18, iso_O17, &
+        ridicule_qsol
+    USE isotopes_routines_mod, ONLY: calcul_iso_surf_ter_vectall
+#ifdef ISOVERIF
+    USE isotopes_verif_mod, ONLY: errmax,errmaxrel,iso_verif_noNaN, &
+        iso_verif_aberrant_o17,iso_verif_egalite_choix,iso_verif_egalite
+#endif
+#endif
 !****************************************************************************************
 ! Bucket calculations for surface. 
@@ -52 +68 @@
     REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
     REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow
+    REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum    
+#endif
 
 ! In/Output variables
@@ -58 +78 @@
     REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
     REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+#ifdef ISO
+    REAL, DIMENSION(niso,klon), INTENT(INOUT)       :: xtsnow,xtsol
+#endif
 
 ! Output variables
@@ -67 +90 @@
     REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
     REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap
+    REAL, DIMENSION(klon),       INTENT(OUT) :: h1
+    REAL, DIMENSION(niso,klon),  INTENT(OUT) :: xtrunoff_diag
+    REAL, DIMENSION(klon),       INTENT(OUT) :: runoff_diag
+    REAL, DIMENSION(niso,klon),  INTENT(IN)  :: Rland_ice
+#endif
 
 ! Local variables
@@ -78 +108 @@
     REAL, DIMENSION(klon) :: dummy_riverflow,dummy_coastalflow 
     INTEGER               :: i
-!
-!****************************************************************************************
-
+#ifdef ISO
+    INTEGER               :: ixt
+    REAL, DIMENSION(niso,klon) :: xtsnow_prec,xtsol_prec
+    REAL, DIMENSION(klon) :: snow_prec,qsol_prec
+    REAL, PARAMETER       :: t_coup = 273.15
+    REAL, DIMENSION(klon) :: fq_fonte_diag
+    REAL, DIMENSION(klon) :: fqfonte_diag
+    REAL, DIMENSION(klon) :: snow_evap_diag 
+    REAL, DIMENSION(klon) :: fqcalving_diag 
+    REAL                  :: max_eau_sol_diag  
+    REAL, DIMENSION(klon) :: run_off_lic_diag 
+    REAL :: coeff_rel_diag
+#endif 
+!
+!****************************************************************************************
+
+#ifdef ISO
+#ifdef ISOVERIF
+        !write(*,*) 'surf_land_bucket 152'
+        DO i=1,knon
+          IF (iso_eau > 0) THEN
+            CALL iso_verif_egalite_choix(precip_snow(i), &
+     &                                   xtprecip_snow(iso_eau,i),'surf_land_bucket 131', &
+     &                                   errmax,errmaxrel)
+            CALL iso_verif_egalite_choix(qsol(i), &
+     &                                   xtsol(iso_eau,i),'surf_land_bucket 134', &
+     &                                   errmax,errmaxrel)
+          ENDIF
+        ENDDO
+#endif 
+#ifdef ISOVERIF
+        DO i=1,knon
+          DO ixt=1,niso
+            CALL iso_verif_noNaN(xtsol(ixt,i),'surf_land_mod_bucket 142')
+          ENDDO !do ixt=1,niso
+        ENDDO !do i=1,knon
+        !write(*,*) 'surf_land_bucket 152'
+#endif
+#endif
 
 !
@@ -131 +197 @@
          tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
     
+#ifdef ISO
+   ! verif
+#ifdef ISOVERIF
+    !write(*,*) 'surf_land_bucket 211'
+    DO i=1,knon
+      IF (iso_eau > 0) THEN
+        CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), &
+     &           snow(i),'surf_land_bucket 522', &
+     &           errmax,errmaxrel) 
+      ENDIF !IF (iso_eau > 0) then
+    ENDDO !DO i=1,knon 
+#endif
+   ! end verif
+#endif         
+#ifdef ISO
+    DO i=1,knon
+      snow_prec(i)=snow(i)
+      qsol_prec(i)=qsol(i)
+      DO ixt=1,niso
+        xtsnow_prec(ixt,i)=xtsnow(ixt,i)
+        xtsol_prec(ixt,i) =xtsol(ixt,i)
+      ENDDO !DO ixt=1,niso
+      ! initialisation:
+      fqfonte_diag(i)  =0.0
+      fq_fonte_diag(i) =0.0
+      snow_evap_diag(i)=0.0
+    ENDDO !DO i=1,knon 
+#ifdef ISOVERIF
+    ! write(*,*) 'surf_land_bucket 235'
+    DO i=1,knon  
+      IF (iso_eau > 0) THEN
+        CALL iso_verif_egalite(qsol_prec(i),xtsol_prec(iso_eau,i), &
+    &                              'surf_land_bucket 141')
+      ENDIF
+    ENDDO !DO i=1,knon
+#endif    
+#endif    
 !
 !* Calculate snow height, run_off, age of snow
@@ -136 +239 @@
     CALL fonte_neige( knon, is_ter, knindex, dtime, &
          tsurf, precip_rain, precip_snow, &
-         snow, qsol, tsurf_new, evap)
+         snow, qsol, tsurf_new, evap &
+#ifdef ISO    
+     & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag   &
+     & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag   &
+#endif
+     &   )
+
+#ifdef ISO
+#ifdef ISOVERIF
+        DO i=1,knon
+          DO ixt=1,niso
+            CALL iso_verif_noNaN(xtsol_prec(ixt,i),'surf_land_burcket 237')
+          ENDDO
+        ENDDO
+#endif
+#ifdef ISOVERIF
+        !write(*,*) 'surf_land_bucket 235'
+        DO i=1,knon
+          IF (iso_eau > 0) THEN
+            CALL iso_verif_egalite_choix(qsol_prec(i), &
+     &                                   xtsol_prec(iso_eau,i),'surf_land_bucket 628', &
+     &                                   errmax,errmaxrel)
+            CALL iso_verif_egalite_choix(precip_snow(i), &
+     &                                   xtprecip_snow(iso_eau,i),'surf_land_bucket 227', &
+     &                                   errmax,errmaxrel)
+             ! attention, dans fonte_neige, on modifie snow sans modifier
+             ! xtsnow
+             ! c'est fait plus tard dans gestion_neige
+!            write(*,*) 'surf_land_bucket 287: i=',i
+!            write(*,*) 'snow(i)=',snow(i)
+            CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), &
+     &                                   snow_prec(i),'surf_land_bucket 245', &
+     &                                   errmax,errmaxrel) 
+          ENDIF  
+          IF ((iso_O17 > 0).AND.(iso_O18 > 0)) THEN
+              IF (qsol_prec(i) > ridicule_qsol) THEN
+                CALL iso_verif_aberrant_o17(xtsol_prec(iso_O17,i)/qsol_prec(i) &
+     &                                     ,xtsol_prec(iso_O18,i)/qsol_prec(i) &
+     &                                     ,'surf_land_bucket 642')
+              ENDIF !IF ((qsol_prec(i) > ridicule_qsol) &
+          ENDIF !IF ((iso_O17 > 0).AND.(iso_O18 > 0)) THEN
+        ENDDO  !DO i=1,knon 
+        !write(*,*) 'surf_land_mod 291'
+        !write(*,*) 'snow_evap_diag(1)=',snow_evap_diag(1)
+#endif          
+        CALL calcul_iso_surf_ter_vectall(klon,knon, &
+     &           evap,snow_evap_diag,snow, &
+     &           fq_fonte_diag,fqfonte_diag,dtime,precip_rain,xtprecip_rain, &
+     &           precip_snow,xtprecip_snow, snow_prec,xtsnow_prec, &
+     &           tsurf_new,xtspechum,pref,spechum,t_coup,u1_lay,v1_lay,p1lay, &
+     &           qsol,xtsol,qsol_prec,xtsol_prec, &
+     &           max_eau_sol_diag, &
+     &           xtevap,xtsnow,h1,runoff_diag,xtrunoff_diag,fqcalving_diag, &
+     &           knindex,is_ter,run_off_lic_diag,coeff_rel_diag,Rland_ice &
+     &   )
+!#ifdef ISOVERIF
+!        write(*,*) 'surf_land_bucket 303'
+!#endif
+#endif
+
 !
 !* Calculate the age of snow

LMDZ6/branches/cirrus/libf/phylmd/surf_land_mod.F90

@@ -20 +20 @@
        qsurf, tsurf_new, dflux_s, dflux_l, &
        flux_u1, flux_v1 , & 
-       veget,lai,height)
+       veget,lai,height &
+#ifdef ISO
+       ,xtprecip_rain, xtprecip_snow,xtspechum, &
+       xtsnow, xtsol,xtevap,h1, &
+       runoff_diag,xtrunoff_diag,Rland_ice &
+#endif               
+               )
 
     USE dimphy
@@ -59 +65 @@
     USE calcul_fluxs_mod
     USE indice_sol_mod
+#ifdef ISO
+    use infotrac_phy, ONLY: ntiso,niso
+    use isotopes_mod, ONLY: nudge_qsol, iso_eau
+#ifdef ISOVERIF
+    use isotopes_verif_mod
+#endif
+#endif
+
     USE print_control_mod, ONLY: lunout
 
@@ -92 +106 @@
                                                          ! corresponds to previous sollwdown
     REAL, DIMENSION(klon), INTENT(IN)       :: q2m, t2m
-
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)       :: xtprecip_rain, xtprecip_snow
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)       :: xtspechum
+#endif 
 ! In/Output variables
 !****************************************************************************************
@@ -98 +115 @@
     REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
     REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+#ifdef ISO
+    REAL, DIMENSION(niso,klon), INTENT(INOUT)    :: xtsnow, xtsol
+#endif
 
 ! Output variables
@@ -116 +136 @@
     REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: veget,lai
     REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: height
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(OUT)      :: xtevap
+    REAL, DIMENSION(klon), INTENT(OUT)      :: h1
+    REAL, DIMENSION(niso,klon), INTENT(OUT)      :: xtrunoff_diag
+    REAL, DIMENSION(klon), INTENT(OUT)      :: runoff_diag
+    REAL, DIMENSION(niso,klon), INTENT(IN)        :: Rland_ice
+#endif
 
 ! Local variables
@@ -132 +159 @@
 !albedo SB <<<
 
-
+#ifdef ISO       
+      real, parameter :: t_coup = 273.15
+      real, dimension(klon) :: fqfonte_diag
+      real, dimension(klon) :: snow_evap_diag 
+      real, dimension(klon) :: fqcalving_diag 
+      integer :: ixt
+#endif 
 !****************************************************************************************
 !Total solid precip
@@ -142 +175 @@
 ENDIF
 !****************************************************************************************
+#ifdef ISO
+#ifdef ISOVERIF
+!        write(*,*) 'surf_land_mod 162'
+        do i=1,knon
+          if (iso_eau.gt.0) then
+            call iso_verif_egalite_choix(precip_snow(i), &
+     &          xtprecip_snow(iso_eau,i),'surf_land_mod 129', &
+     &          errmax,errmaxrel)
+            call iso_verif_egalite_choix(qsol(i), &
+     &          xtsol(iso_eau,i),'surf_land_mod 139', &
+     &          errmax,errmaxrel)
+          endif  
+        enddo
+#endif 
+#ifdef ISOVERIF
+!       write(*,*) 'surf_land 169: ok_veget=',ok_veget
+        do i=1,knon
+         do ixt=1,ntiso
+           call iso_verif_noNaN(xtprecip_snow(ixt,i),'surf_land 146')
+         enddo
+        enddo
+#endif
+#endif
 
 
@@ -172 +228 @@
        END DO
 
+#ifdef ISO
+      CALL abort_gcm('surf_land_mod 220','isos pas prevus dans orchidee',1)
+#endif
        ! temporary for keeping same results using lwdown_m instead of lwdown
        CALL surf_land_orchidee(itime, dtime, date0, knon, &
@@ -183 +242 @@
             tsol_rad, tsurf_new, alb1_new, alb2_new, &
             emis_new, z0m, z0h, qsurf, &
-            veget, lai, height)       
+            veget, lai, height &
+!#ifdef ISO
+!            , xtprecip_rain, xtprecip_snow, xtspechum, xtevap &
+!#endif
+            )                  
+
+#ifdef ISO
+#ifdef ISOVERIF
+     write(*,*) 'surf_land 193: apres surf_land_orchidee'   
+     do i=1,knon
+        if (iso_eau.gt.0) then
+             call iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), &
+    &            'surf_land 197',errmax,errmaxrel)
+        endif !if (iso_eau.gt.0) then      
+      enddo !do i=1,knon  
+#endif
+#endif
 !  
 !* Add contribution of relief to surface roughness
@@ -196 +271 @@
 !
 !****************************************************************************************
+#ifdef ISO
+#ifdef ISOVERIF
+!       write(*,*) 'surf_land 247'
+        call iso_verif_egalite_vect1D( &
+     &           xtsnow,snow,'surf_land_mod 207',niso,klon)
+#endif
+#endif
+
+#ifdef ISO
+        if (nudge_qsol.eq.1) then
+          call surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex)
+        endif
+        !write(*,*) 'surf_land 258'
+#endif
        CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
             tsurf, p1lay, cdragh, precip_rain, precip_totsnow, temp_air, &
@@ -202 +291 @@
             snow, qsol, agesno, tsoil, &
             qsurf, z0m, alb1_new, alb2_new, evap, &
-            fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+            fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l &
+#ifdef ISO
+            ,xtprecip_rain, xtprecip_snow,xtspechum, &
+            xtsnow, xtsol,xtevap,h1, &
+     &      runoff_diag, xtrunoff_diag,Rland_ice &
+#endif           
+     &       )
         z0h(1:knon)=z0m(1:knon) ! En attendant mieux
 
@@ -224 +319 @@
          p1lay, temp_air, &
          flux_u1, flux_v1)
+
+#ifdef ISO
+#ifdef ISOVERIF
+!     write(*,*) 'surf_land 237: sortie'   
+      DO i=1,knon
+        IF (iso_eau >= 0) THEN
+             call iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), &
+    &            'surf_land 241',errmax,errmaxrel)
+        ENDIF !if (iso_eau.gt.0) then      
+      ENDDO !do i=1,knon  
+#endif
+#endif
 
 !albedo SB >>>
@@ -248 +355 @@
     
   END SUBROUTINE surf_land
+
+
+#ifdef ISO
+  SUBROUTINE surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex)
+
+    USE dimphy   
+    USE infotrac_phy, ONLY: niso
+    USE isotopes_mod, ONLY: region_nudge_qsol    
+    INTEGER, INTENT(IN)                       :: knon         
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(INOUT)      :: qsol
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex    
+    REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsol 
+    REAL :: lat_min_nudge_qsol,lat_max_nudge_qsol
+    REAL :: lon_min_nudge_qsol,lon_max_nudge_qsol
+    INTEGER :: i,ixt
+    REAL :: qsol_new
+
+    IF (region_nudge_qsol == 1) THEN
+        ! Aamzonie du Sud
+        lat_min_nudge_qsol=-15.0
+        lat_max_nudge_qsol=-5.0
+        lon_min_nudge_qsol=-70.0
+        lon_max_nudge_qsol=-50.0
+    ELSE IF (region_nudge_qsol == 2) THEN
+        ! Aamzonie du Nord
+        lat_min_nudge_qsol=-5.0
+        lat_max_nudge_qsol=5.0
+        lon_min_nudge_qsol=-70.0
+        lon_max_nudge_qsol=-50.0
+    ELSE
+        WRITE(*,*) 'surf_land 298: cas pas prevu'
+        WRITE(*,*) 'region_nudge_qsol=',region_nudge_qsol
+        stop
+    ENDIF
+
+!    write(*,*) 'surf_land 314: knon=',knon
+!    write(*,*) 'rlat=',rlat
+!    write(*,*) 'rlon=',rlon
+!    write(*,*) 'region_nudge_qsol=',region_nudge_qsol
+
+    DO i=1,knon
+      IF ((rlat(knindex(i)) >= lat_min_nudge_qsol).and. &
+  &       (rlat(knindex(i)) <= lat_max_nudge_qsol).and. &
+  &       (rlon(knindex(i)) >= lon_min_nudge_qsol).and. &
+  &       (rlon(knindex(i)) <= lon_max_nudge_qsol)) THEN
+!        write(*,*) 'surf_land 324: bon domaine: rlat,rlon,qsol=', &
+!  &             rlat(knindex(i)),rlon(knindex(i)),qsol(knindex(i))
+        qsol_new=qsol(i)
+        IF (region_nudge_qsol == 1) THEN   
+           qsol_new=max(qsol(i),50.0)   
+        ELSE IF (region_nudge_qsol == 2) THEN      
+           qsol_new=max(qsol(i),120.0)
+        ELSE !if (region_nudge_qsol.eq.1) then
+           WRITE(*,*) 'surf_land 317: cas pas prevu'
+           WRITE(*,*) 'region_nudge_qsol=',region_nudge_qsol
+           STOP
+        ENDIF !if (region_nudge_qsol.eq.1) then
+        IF (qsol(i) > 0.0) THEN
+           DO ixt=1,niso
+              xtsol(ixt,i)=xtsol(ixt,i)*qsol_new/qsol(i)
+           ENDDO
+        ELSE !IF (qsol(i) > 0.0) THEN
+           DO ixt=1,niso
+             xtsol(ixt,i)=0.0
+           ENDDO
+        ENDIF !IF (qsol(i) > 0.0) THEN
+        qsol(i)=qsol_new
+        WRITE(*,*) 'surf_land 346: qsol_new=',qsol(i)      
+     ENDIF ! if ((rlat(i).ge.lat_min_nudge_qsol).and.
+  ENDDO !DO i=1,knon
+
+  END SUBROUTINE surf_land_nudge_qsol
+#endif
+
 !
 !****************************************************************************************

LMDZ6/branches/cirrus/libf/phylmd/surf_landice_mod.F90

@@ -23 +23 @@
        snowhgt, qsnow, to_ice, sissnow, &
        alb3, runoff, &
-       flux_u1, flux_v1)
+       flux_u1, flux_v1 &
+#ifdef ISO
+         &      ,xtprecip_rain, xtprecip_snow,xtspechum,Rland_ice &
+         &      ,xtsnow,xtsol,xtevap &
+#endif               
+           &    )
 
     USE dimphy
@@ -33 +38 @@
     USE phys_local_var_mod, ONLY : zxrhoslic, zxustartlic, zxqsaltlic
     USE phys_output_var_mod, ONLY : snow_o,zfra_o
+#ifdef ISO   
+    USE fonte_neige_mod,  ONLY : xtrun_off_lic
+    USE infotrac_phy,     ONLY : ntiso,niso
+    USE isotopes_routines_mod, ONLY: calcul_iso_surf_lic_vectall
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,ridicule
+    USE isotopes_verif_mod
+#endif
+#endif
+ 
 !FC
     USE ioipsl_getin_p_mod, ONLY : getin_p
@@ -68 +83 @@
     REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)       :: xtprecip_rain, xtprecip_snow 
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)       :: xtspechum 
+#endif
+
 
     LOGICAL,  INTENT(IN)                          :: debut   !true if first step
@@ -85 +105 @@
     REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
     REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+#ifdef ISO
+    REAL, DIMENSION(niso,klon), INTENT(INOUT)     :: xtsnow, xtsol 
+    REAL, DIMENSION(niso,klon), INTENT(INOUT)     :: Rland_ice
+#endif
+
 
 ! Output variables
@@ -108 +133 @@
     REAL, DIMENSION(klon), INTENT(OUT)           :: sissnow
     REAL, DIMENSION(klon), INTENT(OUT)           :: runoff  !Land ice runoff
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(OUT)     :: xtevap     
+!    real, DIMENSION(niso,klon) :: xtrun_off_lic_0_diag ! est une variable globale de
+!    fonte_neige
+#endif
  
 
@@ -120 +150 @@
     REAL, DIMENSION(klon)    :: fqfonte,ffonte
     REAL, DIMENSION(klon)    :: run_off_lic_frac
+#ifdef ISO       
+    REAL, PARAMETER          :: t_coup = 273.15
+    REAL, DIMENSION(klon)    :: fqfonte_diag
+    REAL, DIMENSION(klon)    :: fq_fonte_diag
+    REAL, DIMENSION(klon)    ::  snow_evap_diag 
+    REAL, DIMENSION(klon)    ::  fqcalving_diag 
+    REAL max_eau_sol_diag  
+    REAL, DIMENSION(klon)    ::  runoff_diag 
+    REAL, DIMENSION(klon)    ::    run_off_lic_diag 
+    REAL                     ::  coeff_rel_diag
+    INTEGER                  :: ixt
+    REAL, DIMENSION(niso,klon) :: xtsnow_prec,xtsol_prec
+    REAL, DIMENSION(klon) :: snow_prec,qsol_prec
+!    real, DIMENSION(klon) :: run_off_lic_0_diag
+#endif
+
+
     REAL, DIMENSION(klon)    :: emis_new                  !Emissivity
     REAL, DIMENSION(klon)    :: swdown,lwdown
@@ -146 +193 @@
     REAL, DIMENSION(klon)  :: fluxbs_1, fluxbs_2, bsweight_fresh
     LOGICAL, DIMENSION(klon) :: ok_remaining_freshsnow
+    REAL  :: ta1, ta2, ta3, z01, z02, z03, coefa, coefb, coefc, coefd
+
 
 ! End definition
@@ -161 +210 @@
 !FC firtscall initializations
 !******************************************************************************************
+#ifdef ISO
+#ifdef ISOVERIF
+!     write(*,*) 'surf_land_ice 1499'   
+  DO i=1,knon
+    IF (iso_eau > 0) THEN
+      CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), &
+    &                              'surf_land_ice 126',errmax,errmaxrel)
+    ENDIF !IF (iso_eau > 0) THEN      
+  ENDDO !DO i=1,knon  
+#endif
+#endif
+
   IF (firstcall) THEN
   alb_vis_sno_lic=0.77
@@ -200 +261 @@
 !****************************************************************************************
 #ifdef CPP_INLANDSIS
+
+#ifdef ISO
+        CALL abort_gcm('surf_landice 235','isotopes pas dans INLANDSIS',1)
+#endif
 
         debut_is=debut
@@ -321 +386 @@
          tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
 
+#ifdef ISO
+#ifdef ISOVERIF
+     !write(*,*) 'surf_land_ice 1499'   
+     DO i=1,knon
+       IF (iso_eau > 0) THEN
+         IF (snow(i) > ridicule) THEN
+           CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), &
+    &                                   'surf_land_ice 1151',errmax,errmaxrel)
+         ENDIF !IF ((snow(i) > ridicule)) THEN
+       ENDIF !IF (iso_eau > 0) THEN
+     ENDDO !DO i=1,knon  
+#endif
+
+    DO i=1,knon
+      snow_prec(i)=snow(i)
+      DO ixt=1,niso
+        xtsnow_prec(ixt,i)=xtsnow(ixt,i)
+      ENDDO !DO ixt=1,niso
+      ! initialisation:
+      fq_fonte_diag(i)=0.0
+      fqfonte_diag(i)=0.0
+      snow_evap_diag(i)=0.0 
+    ENDDO !DO i=1,knon 
+#endif         
+
     CALL calcul_flux_wind(knon, dtime, &
          u0, v0, u1, v1, gustiness, cdragm, &
@@ -350 +440 @@
 !
 !****************************************************************************************
-    z0m = z0m_landice
-    z0h = z0h_landice
-    !z0m = SQRT(z0m**2+rugoro**2)
-
+
+if (z0m_landice .GT. 0.) then
+    z0m(1:knon) = z0m_landice
+    z0h(1:knon) = z0h_landice
+else
+    ! parameterization of z0=f(T) following measurements in Adelie Land by Amory et al 2018
+    coefa = 0.1658 !0.1862 !Ant
+    coefb = -50.3869 !-55.7718 !Ant
+    ta1 = 253.15 !255. Ant
+    ta2 = 273.15
+    ta3 = 273.15+3
+    z01 = exp(coefa*ta1 + coefb) !~0.2 ! ~0.25 mm
+    z02 = exp(coefa*ta2 + coefb) !~6  !~7 mm
+    z03 = z01
+    coefc = log(z03/z02)/(ta3-ta2)
+    coefd = log(z03)-coefc*ta3
+    do j=1,knon 
+      if (temp_air(j) .lt. ta1) then
+        z0m(j) = z01
+      else if (temp_air(j).ge.ta1 .and. temp_air(j).lt.ta2) then
+        z0m(j) = exp(coefa*temp_air(j) + coefb)
+      else if (temp_air(j).ge.ta2 .and. temp_air(j).lt.ta3) then
+        ! if st > 0, melting induce smooth surface
+        z0m(j) = exp(coefc*temp_air(j) + coefd)
+      else
+        z0m(j) = z03
+      endif
+      z0h(j)=z0m(j)
+    enddo
+
+endif    
+ 
 
 !****************************************************************************************
@@ -366 +484 @@
    if (ok_bs) then
        fluxbs(:)=0.
-       do j=1,klon
+       do j=1,knon
           ws1(j)=(u1(j)**2+v1(j)**2)**0.5
           ustar(j)=(cdragm(j)*(u1(j)**2+v1(j)**2))**0.5
@@ -493 +611 @@
  
     CALL fonte_neige(knon, is_lic, knindex, dtime, &
-         tsurf, precip_rain, precip_totsnow,  &
-         snow, qsol, tsurf_new, evap_totsnow)
+         tsurf, precip_rain, precip_totsnow, &
+         snow, qsol, tsurf_new, evap_totsnow &
+#ifdef ISO    
+     &  ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag     &
+     &  ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag &
+#endif
+     &   )
+
+
+#ifdef ISO
+#ifdef ISOVERIF
+    DO i=1,knon  
+      IF (iso_eau > 0) THEN  
+        CALL iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, &
+     &                               'surf_landice_mod 217',errmax,errmaxrel)
+      ENDIF !IF (iso_eau > 0) THEN
+    ENDDO !DO i=1,knon
+#endif
+
+    CALL calcul_iso_surf_lic_vectall(klon,knon, &
+     &    evap,snow_evap_diag,Tsurf_new,snow, &
+     &    fq_fonte_diag,fqfonte_diag,dtime,t_coup, &
+     &    precip_snow,xtprecip_snow,precip_rain,xtprecip_rain, snow_prec,xtsnow_prec, &
+     &    xtspechum,spechum,ps,Rland_ice, &
+     &    xtevap,xtsnow,fqcalving_diag, &
+     &    knindex,is_lic,run_off_lic_diag,coeff_rel_diag &
+     &   ) 
+
+!        call fonte_neige_export_xtrun_off_lic_0(knon,xtrun_off_lic_0_diag)
+
+#endif
    
-    
     WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.                                         
     zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))  

LMDZ6/branches/cirrus/libf/phylmd/surf_ocean_mod.F90

@@ -21 +21 @@
        tsurf_new, dflux_s, dflux_l, lmt_bils, &
        flux_u1, flux_v1, delta_sst, delta_sal, ds_ns, dt_ns, dter, dser, &
-       dt_ds, tkt, tks, taur, sss)
+       dt_ds, tkt, tks, taur, sss &
+#ifdef ISO
+        &       ,xtprecip_rain, xtprecip_snow,xtspechum,Roce, &
+        &       xtsnow,xtevap,h1 &
+#endif               
+        &       )
 
     use albedo, only: alboc, alboc_cd
@@ -31 +36 @@
     USE ocean_cpl_mod, ONLY    : ocean_cpl_noice
     USE indice_sol_mod, ONLY : nbsrf, is_oce
+#ifdef ISO
+    USE infotrac_phy, ONLY : ntraciso=>ntiso,niso
+#ifdef ISOVERIF
+    USE isotopes_mod, ONLY: iso_eau,ridicule
+    USE isotopes_verif_mod
+#endif
+#endif
     USE limit_read_mod
-    use config_ocean_skin_m, only: activate_ocean_skin
+    USE config_ocean_skin_m, ONLY: activate_ocean_skin
     !
     ! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, 
@@ -68 +80 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow 
+    REAL, DIMENSION(ntraciso,klon), INTENT(IN) :: xtspechum
+#endif
 
     ! In/Output variables
@@ -75 +91 @@
     REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
     REAL, DIMENSION(klon), INTENT(inOUT)     :: z0h
+#ifdef ISO
+    REAL, DIMENSION(niso,klon), INTENT(IN)   :: xtsnow 
+    REAL, DIMENSION(niso,klon), INTENT(INOUT):: Roce  
+#endif
 
     REAL, intent(inout):: delta_sst(:) ! (knon)
@@ -136 +156 @@
     ! size klon because of the coupling machinery.)
 
+#ifdef ISO
+    REAL, DIMENSION(ntraciso,klon), INTENT(out) :: xtevap ! isotopes in surface evaporation flux 
+    REAL, DIMENSION(klon), INTENT(out)          :: h1 ! just a diagnostic, not useful for the simulation   
+#endif
+
     ! Local variables
     !*************************************************************************
@@ -146 +171 @@
     REAL, DIMENSION(klon) :: precip_totsnow
     CHARACTER(len=20),PARAMETER :: modname="surf_ocean"
-    real rhoa(knon) ! density of moist air  (kg / m3)
+    REAL rhoa(knon) ! density of moist air  (kg / m3)
     REAL sens_prec_liq(knon)
 
     REAL t_int(knon) ! ocean-air interface temperature, in K
-    real s_int(knon) ! ocean-air interface salinity, in ppt
+    REAL s_int(knon) ! ocean-air interface salinity, in ppt
 
     !**************************************************************************
 
+#ifdef ISO
+#ifdef ISOVERIF
+    DO i = 1, knon
+      IF (iso_eau > 0) THEN         
+        CALL iso_verif_egalite_choix(xtspechum(iso_eau,i), &
+     &          spechum(i),'surf_ocean_mod 117', &
+     &          errmax,errmaxrel)          
+        CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), &
+     &          snow(i),'surf_ocean_mod 127', &
+     &          errmax,errmaxrel) 
+      ENDIF !IF (iso_eau > 0) then
+    ENDDO !DO i=1,klon
+#endif      
+#endif
 
     !******************************************************************************
@@ -230 +269 @@
             radsol, snow, agesno, &
             qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-            tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa)
+            tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa &
+#ifdef ISO
+            ,xtprecip_rain, xtprecip_snow, xtspechum,Roce,rlat, &
+            xtsnow,xtevap,h1 &  
+#endif            
+            )
     END SELECT
 

LMDZ6/branches/cirrus/libf/phylmd/surf_seaice_mod.F90

@@ -21 +21 @@
        z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &  
        tsurf_new, dflux_s, dflux_l, &
-       flux_u1, flux_v1)
+       flux_u1, flux_v1 &
+#ifdef ISO
+         &      ,xtprecip_rain, xtprecip_snow,xtspechum,Roce, &
+         &      xtsnow,xtsol,xtevap,Rland_ice &
+#endif               
+         &      )
 
   USE dimphy
@@ -29 +34 @@
   USE ocean_slab_mod, ONLY   : ocean_slab_ice
   USE indice_sol_mod
+#ifdef ISO
+  USE infotrac_phy, ONLY : ntiso,niso
+#endif
 
 !
@@ -62 +70 @@
     REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
     REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(IN)  :: xtprecip_rain, xtprecip_snow 
+    REAL, DIMENSION(klon),       INTENT(IN)  :: xtspechum
+    REAL, DIMENSION(niso,klon),  INTENT(IN)  :: Roce
+    REAL, DIMENSION(niso,klon),  INTENT(IN)  :: Rland_ice
+#endif
 
 ! In/Output arguments
@@ -68 +82 @@
     REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
     REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+#ifdef ISO
+    REAL, DIMENSION(niso,klon), INTENT(INOUT)     :: xtsnow  
+    REAL, DIMENSION(niso,klon), INTENT(IN)        :: xtsol 
+#endif
 
 ! Output arguments
@@ -82 +100 @@
     REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
     REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+#ifdef ISO
+    REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap
+#endif
 
 ! Local arguments
 !****************************************************************************************
     REAL, DIMENSION(klon)  :: radsol
+#ifdef ISO
+#ifdef ISOVERIF
+    INTEGER :: j
+#endif
+#endif
 
 !albedo SB >>>
@@ -145 +171 @@
             radsol, snow, qsol, agesno, tsoil, &
             qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-            tsurf_new, dflux_s, dflux_l, rhoa)
+            tsurf_new, dflux_s, dflux_l, rhoa &
+#ifdef ISO
+            ,xtprecip_rain, xtprecip_snow, xtspechum,Roce, &
+            xtsnow, xtsol,xtevap,Rland_ice &  
+#endif            
+            )
 
     END IF

LMDZ6/branches/cirrus/libf/phylmdiso/add_phys_tend_mod.F90

@@ -957 +957 @@
       bilh_bnd = (-(rcw-rcpd)*t_seri(1,1) + rlvtt) * rain_lsc(1) &
     &         + (-(rcs-rcpd)*t_seri(1,1) + rlstt) * snow_lsc(1)
-  CASE("bs") param
+  CASE("bsss") param
       bilq_bnd = - bs_fall(1)
       bilh_bnd = (-(rcs-rcpd)*t_seri(1,1) + rlstt) * bs_fall(1)

LMDZ6/branches/cirrus/libf/phylmdiso/add_wake_tend.F90

@@ -1 @@
-SUBROUTINE add_wake_tend(zddeltat, zddeltaq, zds, zddensaw, zddensw, zoccur, text, abortphy &
+SUBROUTINE add_wake_tend(zddeltat, zddeltaq, zds, zdas, zddensw, zddensaw, zoccur, text, abortphy &
 #ifdef ISO
         , zddeltaxt &
@@ -13 +13 @@
 
 USE dimphy, ONLY: klon, klev
-USE phys_state_var_mod, ONLY: wake_deltat, wake_deltaq, wake_s,  &
-                              awake_dens, wake_dens
+USE phys_state_var_mod, ONLY: wake_deltat, wake_deltaq, wake_s, awake_s,  &
+                              wake_dens, awake_dens
 
 USE print_control_mod, ONLY: prt_level
@@ -26 +26 @@
 !------------
   REAL, DIMENSION(klon, klev),   INTENT (IN)         :: zddeltat, zddeltaq
-  REAL, DIMENSION(klon),         INTENT (IN)         :: zds, zddensaw, zddensw
+  REAL, DIMENSION(klon),         INTENT (IN)         :: zds, zdas, zddensw, zddensaw
   INTEGER, DIMENSION(klon),      INTENT (IN)         :: zoccur
   CHARACTER*(*),                 INTENT (IN)         :: text
@@ -79 +79 @@
            IF (zoccur(i) .GE. 1) THEN
              wake_s(i)     = wake_s(i)    + zds(i)
+             awake_s(i)    = awake_s(i)    + zdas(i)
+             wake_dens(i)  = wake_dens(i) + zddensw(i)
              awake_dens(i) = awake_dens(i) + zddensaw(i)
-             wake_dens(i)  = wake_dens(i) + zddensw(i)
            ELSE
              wake_s(i)     = 0.
+             awake_s(i)    = 0.
+             wake_dens(i)  = 0.
              awake_dens(i) = 0.
-             wake_dens(i)  = 0.
            ENDIF   ! (zoccur(i) .GE. 1)
          END DO

LMDZ6/branches/cirrus/libf/phylmdiso/isotopes_mod.F90

@@ -20 +20 @@
 
    !--- Variables not depending on isotopes
-   REAL,    SAVE :: pxtmelt, pxtice, pxtmin, pxtmax
-!$OMP THREADPRIVATE(pxtmelt, pxtice, pxtmin, pxtmax)
-   REAL,    SAVE :: tdifexp, tv0cin, thumxt1
-!$OMP THREADPRIVATE(tdifexp, tv0cin, thumxt1)
+   REAL,    SAVE :: thumxt1
+   !$OMP THREADPRIVATE(thumxt1)
    INTEGER, SAVE :: ntot 
 !$OMP THREADPRIVATE(ntot)
@@ -30 +28 @@
    REAL,    SAVE :: P_veg
 !$OMP THREADPRIVATE(P_veg)
-   REAL,    SAVE :: musi, lambda_sursat
-!$OMP THREADPRIVATE(musi, lambda_sursat)
-   REAL,    SAVE :: Kd
-!$OMP THREADPRIVATE(Kd)
-   REAL,    SAVE :: rh_cste_surf_cond, T_cste_surf_cond
-!$OMP THREADPRIVATE(rh_cste_surf_cond, T_cste_surf_cond)
+   REAL,    SAVE :: lambda_sursat
+!$OMP THREADPRIVATE(lambda_sursat)
    LOGICAL, SAVE :: bidouille_anti_divergence    ! T: regularly, xteau <- q to avoid slow drifts
 !$OMP THREADPRIVATE(bidouille_anti_divergence)
@@ -54 +48 @@
    REAL,    SAVE :: sstlatcrit, dsstlatcrit
 !$OMP THREADPRIVATE(sstlatcrit, dsstlatcrit)
-   REAL,    SAVE :: deltaO18_oce
-!$OMP THREADPRIVATE(deltaO18_oce)
    INTEGER, SAVE :: albedo_prescrit              ! 0: default ; 1: constant albedo
 !$OMP THREADPRIVATE(albedo_prescrit)
@@ -88 +80 @@
    REAL,    SAVE :: fac_modif_evaoce
 !$OMP THREADPRIVATE(fac_modif_evaoce)
+   REAL,    SAVE :: deltaO18_oce
+!$OMP THREADPRIVATE(deltaO18_oce)
    INTEGER, SAVE :: ok_bidouille_wake
 !$OMP THREADPRIVATE(ok_bidouille_wake)
@@ -106 +100 @@
                     alpha_liq_sol, Rdefault, Rmethox
 !$OMP THREADPRIVATE(alpha_liq_sol, Rdefault, Rmethox)
-   REAL, SAVE ::    fac_coeff_eq17_liq, fac_coeff_eq17_ice
-!$OMP THREADPRIVATE(fac_coeff_eq17_liq, fac_coeff_eq17_ice)
+!   REAL, SAVE ::    fac_coeff_eq17_liq, fac_coeff_eq17_ice
+!!$OMP THREADPRIVATE(fac_coeff_eq17_liq, fac_coeff_eq17_ice)
+
+   !--- H2[18]O reference
+   REAL, PARAMETER :: fac_enrichoce18=0.0005
+   REAL, PARAMETER :: alpha_liq_sol_O18=1.00291
+   REAL, PARAMETER :: talph1_O18=1137.
+   REAL, PARAMETER :: talph2_O18=-0.4156
+   REAL, PARAMETER :: talph3_O18=-2.0667E-3
+   REAL, PARAMETER :: talps1_O18=11.839
+   REAL, PARAMETER :: talps2_O18=-0.028244
+   REAL, PARAMETER :: tdifrel_O18=1./0.9723
+   REAL, PARAMETER :: tkcin0_O18=0.006
+   REAL, PARAMETER :: tkcin1_O18=0.000285
+   REAL, PARAMETER :: tkcin2_O18=0.00082
+   REAL, PARAMETER :: fac_coeff_eq17_liq=0.529
+   REAL, PARAMETER :: fac_coeff_eq17_ice=0.529
+
+   !---- Parameters that do not depend on the nature of water isotopes:
+   REAL, PARAMETER :: pxtmelt = 273.15 ! temperature at which ice formation starts
+   REAL, PARAMETER :: pxtice  = 273.15-10.0 ! -- temperature at which all condensate is ice:
+   REAL, PARAMETER :: pxtmin = 273.15 - 120.0   ! On ne calcule qu'au dessus de -120°C
+   REAL, PARAMETER :: pxtmax = 273.15 +  60.0   ! On ne calcule qu'au dessus de +60°C
+   REAL, PARAMETER :: tdifexp = 0.58 ! -- a constant for alpha_eff for equilibrium below cloud base:
+   REAL, PARAMETER :: tv0cin  = 7.0 ! wind threshold (m/s) for smooth/rough regime (Merlivat and Jouzel 1979)
+   REAL, PARAMETER :: musi=1.0  ! facteurs lambda et mu dans Si=musi-lambda*T
+   REAL, PARAMETER :: Kd=2.5e-9 ! m2/s ! diffusion dans le sol
+   REAL, PARAMETER :: rh_cste_surf_cond = 0.6 ! cas où cste_surf_cond: on met rhs ou/et Ts cste pour voir
+   REAL, PARAMETER :: T_cste_surf_cond = 288.0
+
 
    !--- Negligible lower thresholds: no need to check for absurd values under these lower limits
@@ -140 +162 @@
    INTEGER :: ixt
 
-   !--- H2[18]O reference
-   REAL :: fac_enrichoce18, alpha_liq_sol_O18, &
-           talph1_O18, talph2_O18, talph3_O18, talps1_O18, talps2_O18, &
-           tkcin0_O18, tkcin1_O18, tkcin2_O18, tdifrel_O18  
-
+ 
    !--- For H2[17]O
    REAL    :: fac_kcin, pente_MWL
@@ -152 +170 @@
    LOGICAL, PARAMETER ::   ok_nocinsat = .FALSE. ! if T: no sursaturation effect for ice
    LOGICAL, PARAMETER :: Rdefault_smow = .FALSE. ! if T: Rdefault=smow; if F: nul
+   LOGICAL, PARAMETER :: tnat1 = .TRUE. ! If T: all tnats are 1.
 
    !--- For [3]H
@@ -157 +176 @@
 
    CHARACTER(LEN=maxlen) :: modname, sxt
-   REAL, ALLOCATABLE :: tmp(:)
 
    modname = 'iso_init'
@@ -214 +232 @@
       CALL get_in('lat_max_albedo', lat_max_albedo,  100.)
    END IF
-   deltaO18_oce=0.0
    CALL get_in('deltaP_BL',           deltaP_BL,     10.0)
    CALL get_in('ruissellement_pluie', ruissellement_pluie, 0)
@@ -249 +266 @@
    CALL get_in('ok_prod_nucl_tritium', ok_prod_nucl_tritium, .FALSE., .FALSE.)
 
-   !--------------------------------------------------------------
-   ! Parameters that do not depend on the nature of water isotopes:
-   !--------------------------------------------------------------
-   ! -- temperature at which ice condensate starts to form (valeur ECHAM?):
-   pxtmelt = 273.15
-
-   ! -- temperature at which all condensate is ice:
-   pxtice  = 273.15-10.0
-
-   !- -- test PHASE
-!   pxtmelt = 273.15 - 10.0
-!   pxtice  = 273.15 - 30.0
-
-   ! -- minimum temperature to calculate fractionation coeff
-   pxtmin = 273.15 - 120.0   ! On ne calcule qu'au dessus de -120°C
-   pxtmax = 273.15 +  60.0   ! On ne calcule qu'au dessus de +60°C
-   !    Remarque: les coeffs ont ete mesures seulement jusq'à -40!
-
-   ! -- a constant for alpha_eff for equilibrium below cloud base:
-   tdifexp = 0.58
-   tv0cin  = 7.0
-
-   ! facteurs lambda et mu dans Si=musi-lambda*T
-   musi=1.0
-   if (ok_nocinsat) lambda_sursat = 0.0          ! no sursaturation effect
-
-   ! diffusion dans le sol
-   Kd=2.5e-9 ! m2/s   
-
-   ! cas où cste_surf_cond: on met rhs ou/et Ts cste pour voir
-   rh_cste_surf_cond = 0.6
-    T_cste_surf_cond = 288.0
+   ! Ocean composition
+   CALL get_in('deltaO18_oce',  deltaO18_oce, 0.0)
    
    CALL msg('iso_O18, iso_HDO, iso_eau = '//TRIM(strStack(int2str([iso_O18, iso_HDO, iso_eau]))), modname)
 
    !--------------------------------------------------------------
-   ! Parameters that depend on the nature of water isotopes:
+   ! Isotope fractionation factors and a few isotopic constants
    !--------------------------------------------------------------
-   IF(getKey('tnat',    tnat,    isoName)) CALL abort_physic(modname, 'can''t get tnat',    1)
-   IF(getKey('toce',    toce,    isoName)) CALL abort_physic(modname, 'can''t get toce',    1)
-   IF(getKey('tcorr',   tcorr,   isoName)) CALL abort_physic(modname, 'can''t get tcorr',   1)
-   IF(getKey('talph1',  talph1,  isoName)) CALL abort_physic(modname, 'can''t get talph1',  1)
-   IF(getKey('talph2',  talph2,  isoName)) CALL abort_physic(modname, 'can''t get talph2',  1)
-   IF(getKey('talph3',  talph3,  isoName)) CALL abort_physic(modname, 'can''t get talph3',  1)
-   IF(getKey('talps1',  talps1,  isoName)) CALL abort_physic(modname, 'can''t get talps1',  1)
-   IF(getKey('talps2',  talps2,  isoName)) CALL abort_physic(modname, 'can''t get talps2',  1)
-   IF(getKey('tkcin0',  tkcin0,  isoName)) CALL abort_physic(modname, 'can''t get tkcin0',  1)
-   IF(getKey('tkcin1',  tkcin1,  isoName)) CALL abort_physic(modname, 'can''t get tkcin1',  1)
-   IF(getKey('tkcin2',  tkcin2,  isoName)) CALL abort_physic(modname, 'can''t get tkcin2',  1)
-   IF(getKey('tdifrel', tdifrel, isoName)) CALL abort_physic(modname, 'can''t get tdifrel', 1)
-   IF(getKey('alpha_liq_sol', alpha_liq_sol, isoName)) CALL abort_physic(modname, 'can''t get alpha_liq_sol',  1)
-   IF(getKey('Rdefault',Rdefault,isoName)) CALL abort_physic(modname, 'can''t get Rdefault',1)
-   IF(getKey('Rmethox', Rmethox, isoName)) CALL abort_physic(modname, 'can''t get Rmethox', 1)
+   ALLOCATE(tkcin0(niso))
+   ALLOCATE(tkcin1(niso))
+   ALLOCATE(tkcin2(niso))
+   ALLOCATE(tnat(niso))
+   ALLOCATE(tdifrel(niso))
+   ALLOCATE(toce(niso))
+   ALLOCATE(tcorr(niso))
+   ALLOCATE(talph1(niso))
+   ALLOCATE(talph2(niso))
+   ALLOCATE(talph3(niso))
+   ALLOCATE(talps1(niso))
+   ALLOCATE(talps2(niso))
+   ALLOCATE(alpha_liq_sol(niso))
+   ALLOCATE(Rdefault(niso))
+   ALLOCATE(Rmethox(niso))
+
+   do ixt=1,niso
+     if (ixt.eq.iso_HTO) then  ! Tritium
+       tkcin0(ixt) = 0.01056
+       tkcin1(ixt) = 0.0005016
+       tkcin2(ixt) = 0.0014432
+       if (tnat1) then 
+               tnat(ixt)=1 
+       else 
+               tnat(ixt)=0.
+       endif
+       toce(ixt)=4.0E-19 ! rapport T/H = 0.2 TU Dreisigacker and Roether 1978
+       tcorr(ixt)=1.
+       tdifrel(ixt)=1./0.968
+       talph1(ixt)=46480.
+       talph2(ixt)=-103.87
+       talph3(ixt)=0.
+       talps1(ixt)=46480.
+       talps2(ixt)=-103.87
+       alpha_liq_sol(ixt)=1. 
+       Rmethox(ixt)=0.0
+     endif
+     if (ixt.eq.iso_O17) then  ! O17
+       pente_MWL=0.528 
+       tdifrel(ixt)=1./0.98555 ! valeur utilisée en 1D et dans modèle de LdG ! tdifrel(ixt)=1./0.985452 ! donné par Amaelle
+       fac_kcin= (tdifrel(ixt)-1.0)/(tdifrel_O18-1.0) ! fac_kcin=0.5145 ! donné par Amaelle
+       tkcin0(ixt) = tkcin0_O18*fac_kcin
+       tkcin1(ixt) = tkcin1_O18*fac_kcin
+       tkcin2(ixt) = tkcin2_O18*fac_kcin
+       if (tnat1) then 
+               tnat(ixt)=1 
+       else 
+               tnat(ixt)=0.004/100. ! O17 représente 0.004% de l'oxygène
+       endif
+       toce(ixt)=tnat(ixt)*(1.0+deltaO18_oce/1000.0)**pente_MWL
+       tcorr(ixt)=1.0+fac_enrichoce18*pente_MWL ! donné par Amaelle            
+       talph1(ixt)=talph1_O18
+       talph2(ixt)=talph2_O18
+       talph3(ixt)=talph3_O18
+       talps1(ixt)=talps1_O18
+       talps2(ixt)=talps2_O18     
+       alpha_liq_sol(ixt)=(alpha_liq_sol_O18)**fac_coeff_eq17_liq 
+       Rdefault(ixt)=tnat(ixt)*(-3.15/1000.0+1.0)
+       Rmethox(ixt)=(230./1000.+1.)*tnat(ixt) !Zahn et al 2006
+     endif
+     if (ixt.eq.iso_O18) then  ! Oxygene18
+       tkcin0(ixt) = tkcin0_O18
+       tkcin1(ixt) = tkcin1_O18
+       tkcin2(ixt) = tkcin2_O18
+       if (tnat1) then
+               tnat(ixt)=1 
+       else 
+               tnat(ixt)=2005.2E-6
+       endif
+       toce(ixt)=tnat(ixt)*(1.0+deltaO18_oce/1000.0)
+       tcorr(ixt)=1.0+fac_enrichoce18
+       tdifrel(ixt)=tdifrel_O18
+       talph1(ixt)=talph1_O18
+       talph2(ixt)=talph2_O18
+       talph3(ixt)=talph3_O18
+       talps1(ixt)=talps1_O18
+       talps2(ixt)=talps2_O18
+       alpha_liq_sol(ixt)=alpha_liq_sol_O18   
+       Rdefault(ixt)=tnat(ixt)*(-6.0/1000.0+1.0)
+       Rmethox(ixt)=(130./1000.+1.)*tnat(ixt) !Zahn et al 2006  
+     endif
+     if (ixt.eq.iso_HDO) then ! Deuterium
+       pente_MWL=8.0
+       tdifrel(ixt)=1./0.9755 !          fac_kcin=0.88
+       fac_kcin= (tdifrel(ixt)-1)/(tdifrel_O18-1)
+       tkcin0(ixt) = tkcin0_O18*fac_kcin
+       tkcin1(ixt) = tkcin1_O18*fac_kcin
+       tkcin2(ixt) = tkcin2_O18*fac_kcin
+       if (tnat1) then 
+               tnat(ixt)=1
+       else
+               tnat(ixt)=155.76E-6
+       endif
+       toce(ixt)=tnat(ixt)*(1.0+pente_MWL*deltaO18_oce/1000.0)
+       tcorr(ixt)=1.0+fac_enrichoce18*pente_MWL          
+       talph1(ixt)=24844.
+       talph2(ixt)=-76.248
+       talph3(ixt)=52.612E-3
+       talps1(ixt)=16288.
+       talps2(ixt)=-0.0934
+       !ZXalpha_liq_sol=1.0192 ! Weston, Ralph, 1955
+       alpha_liq_sol(ixt)=1.0212 
+       ! valeur de Lehmann & Siegenthaler, 1991, Journal of
+       ! Glaciology, vol 37, p 23
+       Rdefault(ixt)=tnat(ixt)*((-6.0*pente_MWL+10.0)/1000.0+1.0)
+       Rmethox(ixt)=tnat(ixt)*(-25.0/1000.+1.) ! Zahn et al 2006
+     endif
+     if (ixt.eq.iso_eau) then ! Oxygene16
+       tkcin0(ixt) = 0.0
+       tkcin1(ixt) = 0.0
+       tkcin2(ixt) = 0.0
+       tnat(ixt)=1.
+       toce(ixt)=tnat(ixt)
+       tcorr(ixt)=1.0
+       tdifrel(ixt)=1.
+       talph1(ixt)=0.
+       talph2(ixt)=0.
+       talph3(ixt)=0.
+       talps1(ixt)=0.
+       talph3(ixt)=0.
+       alpha_liq_sol(ixt)=1.
+       Rdefault(ixt)=tnat(ixt)*1.0
+       Rmethox(ixt)=1.0
+     endif
+   enddo ! ixt=1,niso
 
    IF(.NOT.Rdefault_smow) then
@@ -308 +405 @@
    ENDIF
    write(*,*) 'Rdefault=',Rdefault
+   write(*,*) 'toce=',toce
 
    !--- Sensitivity test: no kinetic effect in sfc evaporation

LMDZ6/branches/cirrus/libf/phylmdiso/isotopes_routines_mod.F90

@@ -1525 +1525 @@
 #endif       
        pxtfra=max(min(pxtfra,alpha_max),0.0)
-
 
       end subroutine fractcalk_liq
@@ -15922 +15921 @@
 
       ! verif
-!      text="phyisoetat0 67"
-!      write(*,*) 'snow(8,1)=',snow(8,1)
-!      write(*,*) 'xtsnow(4,8,1)=',xtsnow(4,8,1)
 #ifdef ISOVERIF
       do i=1,klon
@@ -15934 +15930 @@
          enddo !do ixt=1,niso
       enddo !do i=1,klon
-#endif      
-#ifdef ISOVERIF
       do i=1,klon
          if (iso_eau.gt.0) then
@@ -16021 +16015 @@
          endif 
        enddo !do i=1,klon
-
 #endif
       !end verif
@@ -16128 +16121 @@
           deltaD_run_off_lic_0(ixt)=deltaD_sol(ixt)
           deltaD_land_ice(ixt)=deltaD_snow(ixt)
-          call fractcalk_liq(ixt, 283.0, alpha(ixt))            
+          call fractcalk_liq(ixt, 283.0, alpha(ixt))    
         enddo !do ixt=1,niso
         call calcul_kcin(2.0,kcin) 
@@ -18830 +18823 @@
         if ((iso_HDO.gt.0).and.(ixt.eq.iso_HDO)) then
             if (q.gt.ridicule) then
+                    write(*,*) 'xt,q=',xt,q
+                    write(*,*) 'alpha=',alpha
+                    write(*,*) 'toce,kcin,h0=',toce,kcin,h0
+                    write(*,*) 'RMerlivat=',RMerlivat
                 call iso_verif_aberrant_encadre( xt/q, 'isotopes_routines_mod 18930b: iso_init_ideal')
             endif
@@ -18902 +18899 @@
 end subroutine appel_stewart_debug
 
+
+subroutine dispatch(klon,klev,qx,q_seri,xt_seri,ql_seri,xtl_seri,qs_seri,xts_seri)
+
+use infotrac_phy, ONLY: nqtot,nqo,ivap,iliq,isol,iqIsoPha,ntraciso=>ntiso
+implicit none
+
+! inputs
+integer, intent(in) :: klon,klev
+real,dimension(klon,klev,nqtot), intent(in) ::qx
+
+! outputs
+real,dimension(klon,klev), intent(out) ::q_seri,ql_seri,qs_seri
+real,dimension(ntraciso,klon,klev), intent(out) :: xt_seri,xtl_seri,xts_seri
+
+! locals
+integer :: i,k,ixt
+
+do k=1,klev
+do i=1,klon
+    q_seri(i,k)  = qx(i,k,ivap)
+    ql_seri(i,k) = qx(i,k,iliq)
+    IF (nqo.EQ.2) THEN             !--vapour and liquid only
+             qs_seri(i,k) = 0.
+    ELSE IF (nqo.ge.3) THEN        !--vapour, liquid and ice
+             qs_seri(i,k) = qx(i,k,isol)
+    ENDIF
+    do ixt=1,ntraciso
+          xt_seri(ixt,i,k)  = qx(i,k,iqIsoPha(ixt,ivap))
+          xtl_seri(ixt,i,k) = qx(i,k,iqIsoPha(ixt,iliq))
+          if (nqo.eq.2) then
+             xts_seri(ixt,i,k) = 0.
+          else if (nqo.eq.3) then
+             xts_seri(ixt,i,k) = qx(i,k,iqIsoPha(ixt,isol))
+          endif
+    enddo !do ixt=1,niso
+
+enddo
+enddo
+
+end subroutine dispatch
+
+subroutine together(klon,klev,qx,q_seri,xt_seri,ql_seri,xtl_seri,qs_seri,xts_seri)
+
+use infotrac_phy, ONLY: nqtot,nqo,ivap,iliq,isol,iqIsoPha,ntraciso=>ntiso
+implicit none
+
+! inputs
+integer, intent(in) :: klon,klev
+real,dimension(klon,klev), intent(in) ::q_seri,ql_seri,qs_seri
+real,dimension(ntraciso,klon,klev), intent(in) :: xt_seri,xtl_seri,xts_seri
+
+! inputs
+real,dimension(klon,klev,nqtot), intent(out) ::qx
+
+! locals
+integer :: i,k,ixt
+
+do k=1,klev
+do i=1,klon  
+    qx(i,k,ivap)  = q_seri(i,k)
+    qx(i,k,iliq) = ql_seri(i,k)
+    IF (nqo.ge.3) THEN        !--vapour, liquid and ice
+             qx(i,k,isol) = qs_seri(i,k)
+    ENDIF
+    do ixt=1,ntraciso
+          qx(i,k,iqIsoPha(ixt,ivap)) = xt_seri(ixt,i,k)  
+          qx(i,k,iqIsoPha(ixt,iliq)) = xtl_seri(ixt,i,k)
+          if (nqo.ge.3) then
+             qx(i,k,iqIsoPha(ixt,isol)) = xts_seri(ixt,i,k)
+          endif
+    enddo !do ixt=1,niso
+
+enddo
+enddo
+
+end subroutine together
+
+
 END MODULE isotopes_routines_mod
 #endif

LMDZ6/branches/cirrus/libf/phylmdiso/isotopes_verif_mod.F90

@@ -1042 +1042 @@
             write(*,*) 'deltaD=',deltaD
             write(*,*) 'Dexcess=',dexcess
+            write(*,*) 'tnat=',tnat
 !            stop
             iso_verif_O18_aberrant_nostop=1

LMDZ6/branches/cirrus/libf/phylmdiso/isotrac_routines_mod.F90

@@ -681 +681 @@
               Eqi_prime_cas(il)=Eqi_prime(cas(il)) &
      &           *(Pxtisup(ieau,cas(il))/Pqisup(cas(il)))
-              Eqi_cas(il)=Eqi(il) &
+              Eqi_cas(il)=Eqi(cas(il)) & ! corr bug Camille 15 juin 2024
      &           *(Pxtisup(ieau,cas(il))/Pqisup(cas(il)))
             else

LMDZ6/branches/cirrus/libf/phylmdiso/phyetat0_mod.F90

@@ -30 +30 @@
        solsw, solswfdiff, t_ancien, u_ancien, v_ancien, w01, wake_cstar, wake_deltaq, &
        wake_deltat, wake_delta_pbl_TKE, delta_tsurf, beta_aridity, wake_fip, wake_pe, &
-       wake_s, wake_dens, awake_dens, cv_gen, zgam, zmax0, zmea, zpic, zsig, &
+       wake_s, awake_s, wake_dens, awake_dens, cv_gen, zgam, zmax0, zmea, zpic, zsig, &
 #ifdef ISO
        fxtevap, xtsol, xt_ancien, xtl_ancien, xts_ancien, wake_deltaxt, &
@@ -49 +49 @@
   USE time_phylmdz_mod, ONLY: init_iteration, pdtphys, itau_phy
   USE wxios, ONLY: missing_val_xios => missing_val, using_xios
-  use netcdf, only:  nf90_fill_real
+  use netcdf, only: missing_val_netcdf => nf90_fill_real
   use config_ocean_skin_m, only: activate_ocean_skin
 #ifdef ISO
@@ -112 +112 @@
   REAL Rland_ice(niso,klon)
 #endif
+
+  IF (using_xios) THEN
+    missing_val=missing_val_xios
+  ELSE
+    missing_val=missing_val_netcdf
+  ENDIF
+
   ! FH1D
   !     real iolat(jjm+1)
@@ -117 +124 @@
 
   ! Ouvrir le fichier contenant l'etat initial:
-  IF (using_xios) THEN
-    missing_val = missing_val_xios
-  ELSE
-    missing_val =  nf90_fill_real
-  ENDIF
 
   CALL open_startphy(fichnom)
@@ -324 +326 @@
 
 !===================================================================
+! Lecture dans le cas iflag_pbl_surface =1
+!===================================================================
+
+   if ( iflag_physiq <= 1 ) then
+!===================================================================
   ! Lecture des temperatures du sol profond:
 !===================================================================
@@ -351 +358 @@
   found=phyetat0_get(snow_fall,"snow_f","snow fall",0.)
   found=phyetat0_get(rain_fall,"rain_f","rain fall",0.)
-
   IF (ok_bs) THEN
      found=phyetat0_get(bs_fall,"bs_f","blowing snow fall",0.)
@@ -405 +411 @@
   ENDIF
 
+  endif ! iflag_physiq <= 1
+
   ! Lecture de l'age de la neige:
   found=phyetat0_srf(agesno,"AGESNO","SNOW AGE",0.001)
@@ -498 +506 @@
   found=phyetat0_get(wake_deltaq,"WAKE_DELTAQ","Delta hum. wake/env",0.)
   found=phyetat0_get(wake_s,"WAKE_S","Wake frac. area",0.)
+  found=phyetat0_get(awake_s,"AWAKE_S","Active Wake frac. area",0.)
 !jyg<
 !  Set wake_dens to -1000. when there is no restart so that the actual
@@ -677 +686 @@
 !        write(*,*) 'xtsnow(:,994,2)=',xtsnow(:,994,2)
 !#endif
-
+  if ( iflag_physiq <= 1 ) then
   CALL pbl_surface_init(fder, snow, qsurf, tsoil)
 #ifdef ISO
   CALL pbl_surface_init_iso(xtsnow,Rland_ice)
 #endif
+  endif
 
   ! Initialize module ocean_cpl_mod for the case of coupled ocean

LMDZ6/branches/cirrus/libf/phylmdiso/phys_local_var_mod.F90

@@ -14 +14 @@
       REAL, SAVE, ALLOCATABLE :: ql_seri(:,:),qs_seri(:,:)
       !$OMP THREADPRIVATE(ql_seri,qs_seri)
+! SN 15/07/2024 ISO 4D
+      REAL, SAVE, ALLOCATABLE :: qx_seri(:,:,:)
+      !$OMP THREADPRIVATE(qx_seri)
+! SN
       REAL, SAVE, ALLOCATABLE :: qbs_seri(:,:)
       !$OMP THREADPRIVATE(qbs_seri)
@@ -24 +28 @@
       REAL, SAVE, ALLOCATABLE :: pbl_eps(:,:,:)
       !$OMP THREADPRIVATE(pbl_eps)
+      REAL, SAVE, ALLOCATABLE :: tke_shear(:,:,:), tke_buoy(:,:,:), tke_trans(:,:,:)
+      !$OMP THREADPRIVATE(tke_shear,tke_buoy,tke_trans)
       REAL, SAVE, ALLOCATABLE :: tr_seri(:,:,:)
       !$OMP THREADPRIVATE(tr_seri)
@@ -64 +70 @@
       REAL, SAVE, ALLOCATABLE :: d_t_eva(:,:),d_q_eva(:,:),d_ql_eva(:,:),d_qi_eva(:,:)
       !$OMP THREADPRIVATE(d_t_eva,d_q_eva,d_ql_eva,d_qi_eva)
+! SN 15/07/2024 ISO 4D
+      REAL, SAVE, ALLOCATABLE :: d_qx_eva(:,:,:)
+      !$OMP THREADPRIVATE(d_qx_eva)
+! SN
       REAL, SAVE, ALLOCATABLE :: d_t_lscst(:,:),d_q_lscst(:,:)
       !$OMP THREADPRIVATE(d_t_lscst,d_q_lscst)
@@ -84 +94 @@
       REAL, SAVE, ALLOCATABLE :: d_t_vdf_x(:,:), d_q_vdf_x(:,:)
       !$OMP THREADPRIVATE( d_t_vdf_x, d_q_vdf_x)
-      REAL, SAVE, ALLOCATABLE :: d_t_bs(:,:), d_q_bs(:,:), d_qbs_bs(:,:)
-      !$OMP THREADPRIVATE( d_t_bs,d_q_bs, d_qbs_bs)
+      REAL, SAVE, ALLOCATABLE :: d_t_bsss(:,:), d_q_bsss(:,:), d_qbs_bsss(:,:)
+      !$OMP THREADPRIVATE( d_t_bsss,d_q_bsss, d_qbs_bsss)
 !>nrlmd+jyg
       REAL, SAVE, ALLOCATABLE :: d_t_oro(:,:)
@@ -124 +134 @@
       REAL, SAVE, ALLOCATABLE :: xts_seri(:,:,:)
       !$OMP THREADPRIVATE( xts_seri)
+      REAL, SAVE, ALLOCATABLE :: xtbs_seri(:,:,:)
+      !$OMP THREADPRIVATE( xtbs_seri)
       REAL, SAVE, ALLOCATABLE :: d_xt_eva(:,:,:)
       !$OMP THREADPRIVATE( d_xt_eva)
@@ -134 +146 @@
       REAL, SAVE, ALLOCATABLE :: d_xt_dyn(:,:,:)
       !$OMP THREADPRIVATE( d_xt_dyn)
-      REAL, SAVE, ALLOCATABLE :: d_xtl_dyn(:,:,:), d_xts_dyn(:,:,:)
-      !$OMP THREADPRIVATE(d_xtl_dyn, d_xts_dyn)
+      REAL, SAVE, ALLOCATABLE :: d_xtl_dyn(:,:,:), d_xts_dyn(:,:,:), d_xtbs_dyn(:,:,:)
+      !$OMP THREADPRIVATE(d_xtl_dyn, d_xts_dyn, d_xtbs_dyn)
       REAL, SAVE, ALLOCATABLE :: d_xt_con(:,:,:)
       !$OMP THREADPRIVATE( d_xt_con)
@@ -166 +178 @@
       !$OMP THREADPRIVATE(d_ts, d_tr)
 
-! aerosols
-      REAL, SAVE, ALLOCATABLE :: m_allaer (:,:,:)
-      !$OMP THREADPRIVATE(m_allaer)
 ! diagnostique pour le rayonnement
       REAL, SAVE, ALLOCATABLE :: topswad_aero(:),  solswad_aero(:)      ! diag
@@ -292 +301 @@
 !$OMP THREADPRIVATE(toplwad0_aerop, sollwad0_aerop)
 
+!AI 08 2023 ajout pour Ecrad
+      REAL,ALLOCATABLE,SAVE :: topswad_aero_s2(:), solswad_aero_s2(:)
+!$OMP THREADPRIVATE(topswad_aero_s2, solswad_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: topswai_aero_s2(:), solswai_aero_s2(:)
+!$OMP THREADPRIVATE(topswai_aero_s2, solswai_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: topswad0_aero_s2(:), solswad0_aero_s2(:)
+!$OMP THREADPRIVATE(topswad0_aero_s2, solswad0_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: topsw_aero_s2(:,:), topsw0_aero_s2(:,:)
+!$OMP THREADPRIVATE(topsw_aero_s2, topsw0_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: solsw_aero_s2(:,:), solsw0_aero_s2(:,:)
+!$OMP THREADPRIVATE(solsw_aero_s2, solsw0_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: topswcf_aero_s2(:,:), solswcf_aero_s2(:,:)
+!$OMP THREADPRIVATE(topswcf_aero_s2, solswcf_aero_s2)
+! additional LW variables CK
+      REAL,ALLOCATABLE,SAVE :: toplwad_aero_s2(:), sollwad_aero_s2(:)
+!$OMP THREADPRIVATE(toplwad_aero_s2, sollwad_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: toplwai_aero_s2(:), sollwai_aero_s2(:)
+!$OMP THREADPRIVATE(toplwai_aero_s2, sollwai_aero_s2)
+      REAL,ALLOCATABLE,SAVE :: toplwad0_aero_s2(:), sollwad0_aero_s2(:)
+!$OMP THREADPRIVATE(toplwad0_aero_s2, sollwad0_aero_s2)
+
 !Ajout de celles n??cessaires au phys_output_write_mod
       REAL, SAVE, ALLOCATABLE :: tal1(:), pal1(:), pab1(:), pab2(:)
@@ -300 +330 @@
 !$OMP THREADPRIVATE(sens, flwp, fiwp)
 !!
-!FC
+!FC 
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: zxfluxt, zxfluxq
 !$OMP THREADPRIVATE(zxfluxt, zxfluxq)
@@ -315 +345 @@
     REAL, SAVE, ALLOCATABLE,DIMENSION(:,:)          :: d_deltat_wk, d_deltaq_wk
 !$OMP THREADPRIVATE(d_deltat_wk, d_deltaq_wk)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:)            :: d_s_wk, d_dens_a_wk, d_dens_wk
-!$OMP THREADPRIVATE(d_s_wk, d_dens_a_wk, d_dens_wk)
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:)            :: d_s_wk, d_s_a_wk, d_dens_wk, d_dens_a_wk
+!$OMP THREADPRIVATE(d_s_wk, d_s_a_wk, d_dens_wk, d_dens_a_wk)
     REAL, SAVE, ALLOCATABLE,DIMENSION(:,:)          :: d_deltat_wk_gw, d_deltaq_wk_gw
 !$OMP THREADPRIVATE(d_deltat_wk_gw, d_deltaq_wk_gw)
@@ -328 +358 @@
 !!!OMP THREADPRIVATE(d_s_the, d_dens_the)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)           :: d_deltat_ajs_cv, d_deltaq_ajs_cv
-!$OMP THREADPRIVATE(d_deltat_ajs_cv, d_deltaq_ajs_cv)                       
+!$OMP THREADPRIVATE(d_deltat_ajs_cv, d_deltaq_ajs_cv)
 #ifdef ISO
     REAL, SAVE, ALLOCATABLE,DIMENSION(:,:,:)          :: d_deltaxt_wk
@@ -376 +406 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfluxlat, zxtsol, snow_lsc, zxfqfonte
 !$OMP THREADPRIVATE(zxfluxlat, zxtsol, snow_lsc, zxfqfonte)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxrunofflic
-!$OMP THREADPRIVATE(zxrunofflic)
+!SN runoffdiag
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxrunofflic, runoff_diag
+!$OMP THREADPRIVATE(zxrunofflic, runoff_diag)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxqsurf, rain_lsc, rain_num
 !$OMP THREADPRIVATE(zxqsurf, rain_lsc, rain_num)
@@ -383 +414 @@
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: xtevap,xtprw
 !$OMP THREADPRIVATE(xtevap,xtprw)
-      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: h1_diag,runoff_diag
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: h1_diag
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: xtrunoff_diag
-!$OMP THREADPRIVATE(h1_diag,runoff_diag,xtrunoff_diag)
+!$OMP THREADPRIVATE(h1_diagv,xtrunoff_diag)
       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: zxfxtcalving
 !$OMP THREADPRIVATE(zxfxtcalving)
@@ -581 +612 @@
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: pfraclr,pfracld
 !$OMP THREADPRIVATE(pfraclr,pfracld)
+      REAL, SAVE, ALLOCATABLE :: cldfraliq(:,:)
+!$OMP THREADPRIVATE(cldfraliq)
+      REAL, SAVE, ALLOCATABLE ::mean_icefracturb(:,:)
+!$OMP THREADPRIVATE(mean_icefracturb)
+      REAL, SAVE, ALLOCATABLE :: sigma2_icefracturb(:,:)
+!$OMP THREADPRIVATE(sigma2_icefracturb)
 
 ! variables de sorties MM
@@ -671 +708 @@
 !
 ! variables for stratospheric aerosol
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: d_q_emiss
+!$OMP THREADPRIVATE(d_q_emiss)
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: R2SO4
 !$OMP THREADPRIVATE(R2SO4)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: R2SO4B
+!$OMP THREADPRIVATE(R2SO4B)
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: DENSO4
 !$OMP THREADPRIVATE(DENSO4)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:, :) :: DENSO4B
+!$OMP THREADPRIVATE(DENSO4B)      
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: f_r_wet
 !$OMP THREADPRIVATE(f_r_wet)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:, :) :: f_r_wetB
+!$OMP THREADPRIVATE(f_r_wetB)
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: decfluxaer
 !$OMP THREADPRIVATE(decfluxaer)
@@ -685 +730 @@
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: SO2_lifetime
 !$OMP THREADPRIVATE(SO2_lifetime)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: H2SO4_lifetime
+!$OMP THREADPRIVATE(H2SO4_lifetime)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: O3_clim
+!$OMP THREADPRIVATE(O3_clim)
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: alpha_bin
 !$OMP THREADPRIVATE(alpha_bin)
@@ -701 +750 @@
       REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vsed_aer
 !$OMP THREADPRIVATE(vsed_aer)
+!     Sulfate aerosol concentration (dry mixing ratio) (condensed H2SO4 mmr)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sulfmmr
+!$OMP THREADPRIVATE(sulfmmr)
+!     SAD all aerosols (cm2/cm3)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: SAD_sulfate
+!$OMP THREADPRIVATE(SAD_sulfate)
+!     Effective radius of wet surface aerosols (cm)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: reff_sulfate
+!$OMP THREADPRIVATE(reff_sulfate)
+!     sulfate MMR in different modes (based on sulfmmr, it must be dry mmr)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sulfmmr_mode
+!$OMP THREADPRIVATE(sulfmmr_mode)
+!     particle concentration in different modes (part/m3)
+      REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nd_mode
+!$OMP THREADPRIVATE(nd_mode)
 !
 !---3D budget variables
@@ -749 +813 @@
 SUBROUTINE phys_local_var_init
 USE dimphy
-USE infotrac_phy, ONLY : nbtr
+USE infotrac_phy, ONLY : nbtr,nqtot
 #ifdef ISO
 USE infotrac_phy, ONLY : ntraciso=>ntiso,niso
@@ -757 +821 @@
 USE phys_output_var_mod
 USE phys_state_var_mod
+#ifdef CPP_StratAer
+USE infotrac_phy, ONLY : nbtr_bin
+#endif
 
 IMPLICIT NONE
       ALLOCATE(t_seri(klon,klev),q_seri(klon,klev),ql_seri(klon,klev),qs_seri(klon,klev), qbs_seri(klon,klev))
+! SN 4D ISO
+      ALLOCATE(qx_seri(klon,klev,nqtot))
+! SN
       ALLOCATE(u_seri(klon,klev),v_seri(klon,klev))
       ALLOCATE(cf_seri(klon,klev),rvc_seri(klon,klev))
       ALLOCATE(l_mixmin(klon,klev+1,nbsrf),l_mix(klon,klev+1,nbsrf),wprime(klon,klev+1,nbsrf))
       ALLOCATE(pbl_eps(klon,klev+1,nbsrf+1))
+      ALLOCATE(tke_shear(klon,klev+1,nbsrf), tke_buoy(klon,klev+1,nbsrf), tke_trans(klon,klev+1,nbsrf))
       pbl_eps(:,:,:)=0.
+      tke_shear(:,:,:)=0.; tke_buoy(:,:,:)=0.; tke_trans(:,:,:)=0.
       l_mix(:,:,:)=0.;l_mixmin(:,:,:)=0.;wprime(:,:,:)=0. ! doit etre initialse car pas toujours remplis
       ALLOCATE(rhcl(klon,klev))
@@ -789 +861 @@
       ALLOCATE(d_u_ajs(klon,klev),d_v_ajs(klon,klev))
       ALLOCATE(d_t_eva(klon,klev),d_q_eva(klon,klev))
+! SN 4D ISO
+      ALLOCATE(d_qx_eva(klon,klev,nqtot))
+! SN 
       ALLOCATE(d_ql_eva(klon,klev),d_qi_eva(klon,klev))
       ALLOCATE(d_t_lscst(klon,klev),d_q_lscst(klon,klev))
@@ -795 +870 @@
       ALLOCATE(d_t_vdf(klon,klev),d_q_vdf(klon,klev),d_t_diss(klon,klev))
       ALLOCATE (d_qbs_vdf(klon,klev))
-      ALLOCATE(d_t_bs(klon,klev),d_q_bs(klon,klev),d_qbs_bs(klon,klev))
+      ALLOCATE(d_t_bsss(klon,klev),d_q_bsss(klon,klev),d_qbs_bsss(klon,klev))
       ALLOCATE(d_t_vdf_w(klon,klev),d_q_vdf_w(klon,klev))
       ALLOCATE(d_t_vdf_x(klon,klev),d_q_vdf_x(klon,klev))
@@ -802 +877 @@
       allocate(xtl_seri(ntraciso,klon,klev))
       allocate(xts_seri(ntraciso,klon,klev))
+      allocate(xtbs_seri(ntraciso,klon,klev))
       allocate(d_xt_dyn(ntraciso,klon,klev))
       allocate(d_xtl_dyn(ntraciso,klon,klev))
       allocate(d_xts_dyn(ntraciso,klon,klev))
+      allocate(d_xtbs_dyn(ntraciso,klon,klev))
       allocate(d_xt_con(ntraciso,klon,klev))
       allocate(d_xt_wake(ntraciso,klon,klev))
@@ -835 +912 @@
       ALLOCATE(d_u_lif(klon,klev),d_v_lif(klon,klev))
       ALLOCATE(d_ts(klon,nbsrf), d_tr(klon,klev,nbtr))
+
 ! Special RRTM
       ALLOCATE(ZLWFT0_i(klon,klev+1),ZSWFT0_i(klon,klev+1),ZFLDN0(klon,klev+1))
@@ -913 +991 @@
       ALLOCATE(toplwad0_aerop(klon), sollwad0_aerop(klon))
 
+!AI Ajout Ecrad (3Deffect)
+      ALLOCATE(topswad_aero_s2(klon), solswad_aero_s2(klon))
+      ALLOCATE(topswai_aero_s2(klon), solswai_aero_s2(klon))
+      ALLOCATE(topswad0_aero_s2(klon), solswad0_aero_s2(klon))
+      ALLOCATE(topsw_aero_s2(klon,naero_grp), topsw0_aero_s2(klon,naero_grp))
+      ALLOCATE(solsw_aero_s2(klon,naero_grp), solsw0_aero_s2(klon,naero_grp))
+      ALLOCATE(topswcf_aero_s2(klon,naero_grp), solswcf_aero_s2(klon,naero_grp))
+! additional LW variables CK
+      ALLOCATE(toplwad_aero_s2(klon), sollwad_aero_s2(klon))
+      ALLOCATE(toplwai_aero_s2(klon), sollwai_aero_s2(klon))
+      ALLOCATE(toplwad0_aero_s2(klon), sollwad0_aero_s2(klon))
+
 ! FH Ajout de celles necessaires au phys_output_write_mod
 
@@ -923 +1013 @@
       ALLOCATE(wake_omg(klon, klev))
       ALLOCATE(d_deltat_wk(klon, klev), d_deltaq_wk(klon, klev))
-      ALLOCATE(d_s_wk(klon), d_dens_a_wk(klon), d_dens_wk(klon))
+      ALLOCATE(d_s_wk(klon), d_s_a_wk(klon), d_dens_wk(klon), d_dens_a_wk(klon))
       ALLOCATE(d_deltat_wk_gw(klon, klev), d_deltaq_wk_gw(klon, klev))
       ALLOCATE(d_deltat_vdf(klon, klev), d_deltaq_vdf(klon, klev))
@@ -958 +1048 @@
       ALLOCATE(zxfqcalving(klon), zxfluxlat(klon))
       ALLOCATE(zxtsol(klon), snow_lsc(klon), zxfqfonte(klon), zxqsurf(klon))
-      ALLOCATE(zxrunofflic(klon))
+! SN add runoff_diag
+      ALLOCATE(zxrunofflic(klon), runoff_diag(klon))
+      runoff_diag(:)=0.
       ALLOCATE(zxustartlic(klon), zxrhoslic(klon), zxqsaltlic(klon))
       zxustartlic(:)=0. ; zxrhoslic(:)=0. ; zxqsaltlic(:)=0.
@@ -973 +1065 @@
       ALLOCATE(xtrain_lsc(ntraciso,klon))
       ALLOCATE(xtrunoff_diag(niso,klon))
-      ALLOCATE(h1_diag(klon),runoff_diag(klon))
+      ALLOCATE(h1_diag(klon))
+!SN
+      xtrunoff_diag(:,:)=0. ! because variables are only given values on knon grid points
 #endif
 !
@@ -1032 +1126 @@
       ALLOCATE(wfevap(klon, nbsrf))
       ALLOCATE(evap_pot(klon, nbsrf))
-! FC
+! FC 
       ALLOCATE(zxfluxq(klon,klev),zxfluxt(klon,klev))
-!
 !
 !  Deep convective variables used in phytrac
       ALLOCATE(pmflxr(klon, klev+1), pmflxs(klon, klev+1))
       ALLOCATE(wdtrainA(klon,klev),wdtrainS(klon,klev),wdtrainM(klon,klev))
-      ALLOCATE(dnwd(klon, klev), upwd(klon, klev) )
+      ALLOCATE(dnwd(klon, klev), upwd(klon, klev))
       ALLOCATE(ep(klon,klev))                          ! epmax_cape
-      ALLOCATE(da(klon,klev), mp(klon,klev) )
-      ALLOCATE(phi(klon,klev,klev) )
-      ALLOCATE(wght_cvfd(klon,klev) )
-      ALLOCATE(phi2(klon,klev,klev) )
+      ALLOCATE(da(klon,klev), mp(klon,klev))
+      ALLOCATE(phi(klon,klev,klev))
+      ALLOCATE(wght_cvfd(klon,klev))
+      ALLOCATE(phi2(klon,klev,klev))
       ALLOCATE(d1a(klon,klev), dam(klon,klev))
-      ALLOCATE(ev(klon,klev) )
-      ALLOCATE(elij(klon,klev,klev) )
-      ALLOCATE(qtaa(klon,klev) )
-      ALLOCATE(clw(klon,klev) )
-      ALLOCATE(epmlmMm(klon,klev,klev), eplaMm(klon,klev) )
-      ALLOCATE(sij(klon,klev,klev) )
+      ALLOCATE(ev(klon,klev))
+      ALLOCATE(elij(klon,klev,klev))
+      ALLOCATE(qtaa(klon,klev))
+      ALLOCATE(clw(klon,klev))
+      ALLOCATE(epmlmMm(klon,klev,klev), eplaMm(klon,klev))
+      ALLOCATE(sij(klon,klev,klev))
 #ifdef ISO
       ALLOCATE(xtwdtrainA(ntraciso,klon,klev))
@@ -1094 +1187 @@
       ALLOCATE(pfraclr(klon,klev),pfracld(klon,klev))
       pfraclr(:,:)=0. ; pfracld(:,:)=0. ! because not always defined
+      ALLOCATE(cldfraliq(klon,klev))
+      ALLOCATE(sigma2_icefracturb(klon,klev))
+      ALLOCATE(mean_icefracturb(klon,klev))
       ALLOCATE(distcltop(klon,klev))
       ALLOCATE(temp_cltop(klon,klev))
@@ -1134 +1230 @@
 
 #ifdef CPP_StratAer
+      ALLOCATE (d_q_emiss(klon,klev))
       ALLOCATE (R2SO4(klon,klev))
+      ALLOCATE (R2SO4B(klon,klev,nbtr_bin))
       ALLOCATE (DENSO4(klon,klev))
+      ALLOCATE (DENSO4B(klon,klev,nbtr_bin))
       ALLOCATE (f_r_wet(klon,klev))
+      ALLOCATE (f_r_wetB(klon,klev,nbtr_bin))
       ALLOCATE (decfluxaer(klon,nbtr))
       ALLOCATE (mdw(nbtr))
@@ -1147 +1247 @@
       ALLOCATE (OCS_lifetime(klon,klev))
       ALLOCATE (SO2_lifetime(klon,klev))
+      ALLOCATE (H2SO4_lifetime(klon,klev))
+      ALLOCATE (O3_clim(klon,klev))
       ALLOCATE (alpha_bin(nbands_sw_rrtm+nbands_lw_rrtm+nwave,nbtr))
       ALLOCATE (piz_bin(nbands_sw_rrtm+nbands_lw_rrtm+nwave,nbtr))
@@ -1171 +1273 @@
       ALLOCATE (surf_PM25_sulf(klon))
       ALLOCATE (vsed_aer(klon,klev))
+      ALLOCATE (sulfmmr(klon,klev))
+      ALLOCATE (SAD_sulfate(klon,klev))
+      ALLOCATE (reff_sulfate(klon,klev))
+      ALLOCATE (sulfmmr_mode(klon,klev,nbtr_bin))
+      ALLOCATE (nd_mode(klon,klev,nbtr_bin))
 #endif
 
@@ -1181 +1288 @@
 IMPLICIT NONE
       DEALLOCATE(t_seri,q_seri,ql_seri,qs_seri, qbs_seri)
+! SN 4D ISO
+      DEALLOCATE(qx_seri)
+! SN
       DEALLOCATE(u_seri,v_seri)
       DEALLOCATE(cf_seri,rvc_seri)
       DEALLOCATE(l_mixmin,l_mix,wprime)
+      DEALLOCATE(tke_shear,tke_buoy,tke_trans)
       DEALLOCATE(pbl_eps)
       DEALLOCATE(rhcl)
@@ -1208 +1319 @@
       DEALLOCATE(d_u_ajs,d_v_ajs)
       DEALLOCATE(d_t_eva,d_q_eva)
+! SN 4D ISO
+      DEALLOCATE(d_qx_eva)
+! SN
       DEALLOCATE(d_ql_eva,d_qi_eva)
       DEALLOCATE(d_t_lscst,d_q_lscst)
@@ -1214 +1328 @@
       DEALLOCATE(d_t_vdf,d_q_vdf,d_t_diss)
       DEALLOCATE(d_qbs_vdf)
-      DEALLOCATE(d_t_bs,d_q_bs,d_qbs_bs)
-#ifdef ISO
-      deallocate(xt_seri,xtl_seri,xts_seri)
+      DEALLOCATE(d_t_bsss,d_q_bsss,d_qbs_bsss)
+#ifdef ISO
+      deallocate(xt_seri,xtl_seri,xts_seri,xtbs_seri)
       DEALLOCATE(d_xtl_eva,d_xti_eva)
-      deallocate(d_xt_dyn,d_xtl_dyn,d_xts_dyn)
+      deallocate(d_xt_dyn,d_xtl_dyn,d_xts_dyn,d_xtbs_dyn)
       deallocate(d_xt_con)
       deallocate(d_xt_wake)
@@ -1308 +1422 @@
       DEALLOCATE(solsw_aerop, solsw0_aerop)
       DEALLOCATE(topswcf_aerop, solswcf_aerop)
-
 !CK LW diagnostics
       DEALLOCATE(toplwad_aerop, sollwad_aerop)
@@ -1314 +1427 @@
       DEALLOCATE(toplwad0_aerop, sollwad0_aerop)
 
+!AI Ajout pour Ecrad (3Deffect)
+      DEALLOCATE(topswad_aero_s2, solswad_aero_s2)
+      DEALLOCATE(topswai_aero_s2, solswai_aero_s2)
+      DEALLOCATE(topswad0_aero_s2, solswad0_aero_s2)
+      DEALLOCATE(topsw_aero_s2, topsw0_aero_s2)
+      DEALLOCATE(solsw_aero_s2, solsw0_aero_s2)
+      DEALLOCATE(topswcf_aero_s2, solswcf_aero_s2)
+!CK LW diagnostics
+      DEALLOCATE(toplwad_aero_s2, sollwad_aero_s2)
+      DEALLOCATE(toplwai_aero_s2, sollwai_aero_s2)
+      DEALLOCATE(toplwad0_aero_s2, sollwad0_aero_s2)      
+
 ! FH Ajout de celles necessaires au phys_output_write_mod
       DEALLOCATE(tal1, pal1, pab1, pab2)
@@ -1322 +1447 @@
       DEALLOCATE(wake_omg)
       DEALLOCATE(d_deltat_wk, d_deltaq_wk)
-      DEALLOCATE(d_s_wk, d_dens_a_wk, d_dens_wk)
+      DEALLOCATE(d_s_wk, d_s_a_wk, d_dens_wk, d_dens_a_wk)
       DEALLOCATE(d_deltat_wk_gw, d_deltaq_wk_gw)
       DEALLOCATE(d_deltat_vdf, d_deltaq_vdf)
@@ -1353 +1478 @@
       DEALLOCATE(uwat, vwat)
       DEALLOCATE(zxfqcalving, zxfluxlat)
-      DEALLOCATE(zxrunofflic)
+! SN runoff_diag
+      DEALLOCATE(zxrunofflic, runoff_diag)
       DEALLOCATE(zxustartlic, zxrhoslic, zxqsaltlic)
       DEALLOCATE(zxtsol, snow_lsc, zxfqfonte, zxqsurf)
@@ -1382 +1508 @@
       DEALLOCATE(dxtvdf_x, dxtvdf_w)
       DEALLOCATE(xt_therm)
-      DEALLOCATE(h1_diag,runoff_diag,xtrunoff_diag)
+      DEALLOCATE(h1_diag,xtrunoff_diag)
 #endif
 !
@@ -1422 +1548 @@
       DEALLOCATE(upwd, dnwd)
       DEALLOCATE(ep)
-      DEALLOCATE(da, mp )
-      DEALLOCATE(phi )
-      DEALLOCATE(wght_cvfd )
-      DEALLOCATE(phi2 )
+      DEALLOCATE(da, mp)
+      DEALLOCATE(phi)
+      DEALLOCATE(wght_cvfd)
+      DEALLOCATE(phi2)
       DEALLOCATE(d1a, dam)
-      DEALLOCATE(ev )
-      DEALLOCATE(elij )
-      DEALLOCATE(qtaa )
-      DEALLOCATE(clw )
-      DEALLOCATE(epmlmMm, eplaMm )
-      DEALLOCATE(sij )
+      DEALLOCATE(ev)
+      DEALLOCATE(elij)
+      DEALLOCATE(qtaa)
+      DEALLOCATE(clw)
+      DEALLOCATE(epmlmMm, eplaMm)
+      DEALLOCATE(sij)
 #ifdef ISO
       DEALLOCATE(xtwdtrainA)
@@ -1472 +1598 @@
       DEALLOCATE(rneb)
       DEALLOCATE(pfraclr,pfracld)
+      DEALLOCATE(cldfraliq)
+      DEALLOCATE(sigma2_icefracturb)
+      DEALLOCATE(mean_icefracturb)
+      DEALLOCATE (zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic)
       DEALLOCATE(distcltop)
       DEALLOCATE(temp_cltop)
-      DEALLOCATE (zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic)
 #ifdef ISO
       DEALLOCATE (zxxtsnow,xtVprecip,xtVprecipi,pxtrfl,pxtsfl)
@@ -1507 +1636 @@
 #ifdef CPP_StratAer
 ! variables for strat. aerosol CK
-      DEALLOCATE (R2SO4)
-      DEALLOCATE (DENSO4)
-      DEALLOCATE (f_r_wet)
+      DEALLOCATE (d_q_emiss)
+      DEALLOCATE (R2SO4, R2SO4B)
+      DEALLOCATE (DENSO4, DENSO4B)
+      DEALLOCATE (f_r_wet, f_r_wetB)
       DEALLOCATE (decfluxaer)
       DEALLOCATE (mdw)
       DEALLOCATE (SO2_lifetime)
       DEALLOCATE (OCS_lifetime)
+      DEALLOCATE (H2SO4_lifetime)
+      DEALLOCATE (O3_clim)
       DEALLOCATE (alpha_bin)
       DEALLOCATE (piz_bin)
@@ -1522 +1654 @@
       DEALLOCATE (surf_PM25_sulf)
       DEALLOCATE (vsed_aer)
+      DEALLOCATE (sulfmmr)
+      DEALLOCATE (SAD_sulfate)
+      DEALLOCATE (reff_sulfate)
+      DEALLOCATE (sulfmmr_mode)
+      DEALLOCATE (nd_mode)
       DEALLOCATE (budg_3D_ocs_to_so2)
       DEALLOCATE (budg_3D_so2_to_h2so4)

LMDZ6/branches/cirrus/libf/phylmdiso/phys_output_ctrlout_mod.F90

@@ -1112 +1112 @@
   TYPE(ctrl_out), SAVE :: o_tke = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'tke ', 'TKE', 'm2/s2', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_tke_shear = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'tke_shear ', 'TKE shear term', 'm2/s3', (/ ('', i=1, 10) /))  
+  TYPE(ctrl_out), SAVE :: o_tke_buoy = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'tke_buoy ', 'TKE buoyancy term', 'm2/s3', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_tke_trans = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'tke_trans ', 'TKE transport term', 'm2/s3', (/ ('', i=1, 10) /))
   TYPE(ctrl_out), SAVE :: o_tke_dissip = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
-    'tke_dissip ', 'TKE DISSIPATION', 'm2/s3', (/ ('', i=1, 10) /))   
+    'tke_dissip ', 'TKE dissipation term', 'm2/s3', (/ ('', i=1, 10) /))
+
   TYPE(ctrl_out), SAVE :: o_tke_max = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'tke_max', 'TKE max', 'm2/s2',                                  &
@@ -1442 +1449 @@
   TYPE(ctrl_out), SAVE :: o_tau_strat_1020 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
     'OD1020_strat_only', 'Stratospheric Aerosol Optical depth at 1020 nm ', '1', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_SAD_sulfate = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
+    'SAD_sulfate', 'SAD WET sulfate aerosols', 'cm2/cm3', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_reff_sulfate = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
+    'reff_sulfate', 'Effective radius of WET sulfate aerosols', 'cm', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_sulfmmr = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
+    'sulfMMR', 'Sulfate aerosol concentration (dry mass mixing ratio)', 'kg(H2SO4)/kg(air)', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_nd_mode(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_sulfmmr_mode(:)
 !--chemistry
   TYPE(ctrl_out), SAVE :: o_R2SO4 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), &
@@ -1551 +1566 @@
   TYPE(ctrl_out), SAVE :: o_rneb = ctrl_out((/ 2, 5, 10, 10, 10, 10, 11, 11, 11, 11/), &
     'rneb', 'Cloud fraction', '-', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_cldfraliq = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'cldfraliq', 'Liquid fraction of the cloud', '-', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_sigma2_icefracturb = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'sigma2_icefracturb', 'Variance of the diagnostic supersaturation distribution (icefrac_turb) [-]', '-', (/ ('', i=1, 10) /))
+  TYPE(ctrl_out), SAVE :: o_mean_icefracturb = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11/), &
+    'mean_icefracturb', 'Mean of the diagnostic supersaturation distribution (icefrac_turb) [-]', '-', (/ ('', i=1, 10) /))
+ 
   TYPE(ctrl_out), SAVE :: o_rnebjn = ctrl_out((/ 2, 5, 10, 10, 10, 10, 11, 11,11, 11/), &      
     'rnebjn', 'Cloud fraction in day', '-', (/ ('', i=1, 10) /))
@@ -1981 +2003 @@
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dtr_dry(:)
 
-
 #ifdef ISO
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtprecip(:)
@@ -1991 +2012 @@
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtoliq(:)
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtcond(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_xtrunoff_diag(:)
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtdyn(:)
   TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_dxtldyn(:)
@@ -2088 +2110 @@
   TYPE(ctrl_out), SAVE :: o_runoff = ctrl_out((/ 1, 1, 10, 1, 10, 10, 11, 11, 11, 11/), &
     'runoff', 'Run-off rate land ice', 'kg/m2/s', (/ ('', i=1, 10) /))
+! SN add runoff_diag
+!#ifdef ISO
+  TYPE(ctrl_out), SAVE :: o_runoff_diag = ctrl_out((/ 1, 1, 10, 1, 10, 10, 11, 11, 11, 11/), &
+    'runoffland', 'Run-off rate land for bucket', 'kg/m2/s', (/ ('', i=1, 10) /))
+!#endif
   TYPE(ctrl_out), SAVE :: o_albslw3 = ctrl_out((/ 1, 1, 1, 1, 10, 10, 11, 11, 11, 11/), &
     'albslw3', 'Surface albedo LW3', '-', (/ ('', i=1, 10) /))

LMDZ6/branches/cirrus/libf/phylmdiso/physiq_mod.F90

@@ -39 +39 @@
     USE ioipsl_getin_p_mod, ONLY : getin_p
     USE indice_sol_mod
-    USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac
+    USE infotrac_phy, ONLY: nqtot, nbtr, nqo, tracers, type_trac,ivap,iliq,isol
     USE readTracFiles_mod, ONLY: addPhase
     USE strings_mod,  ONLY: strIdx
@@ -93 +93 @@
     USE phys_output_var_mod, ONLY : cloud_cover_sw, cloud_cover_sw_s2
 
+
     !USE cmp_seri_mod
 !    USE add_phys_tend_mod, only : add_pbl_tend, add_phys_tend, diag_phys_tend, prt_enerbil, &
@@ -117 +118 @@
     USE chem_rep, ONLY: Init_chem_rep_xjour, d_q_rep, d_ql_rep, d_qi_rep, &
                         ptrop, ttrop, ztrop, gravit, itroprep, Z1, Z2, fac, B
+    USE strataer_local_var_mod
+    USE strataer_emiss_mod, ONLY: strataer_emiss_init
 #endif
 #if defined INCA || defined REPROBUS
@@ -131 +134 @@
 
 #ifdef CPP_StratAer
+    USE phys_local_var_mod, ONLY: d_q_emiss
     USE strataer_local_var_mod
     USE strataer_nuc_mod, ONLY: strataer_nuc_init
     USE strataer_emiss_mod, ONLY: strataer_emiss_init
 #endif
-
 
     USE lmdz_xios, ONLY: xios_update_calendar, xios_context_finalize
@@ -153 +156 @@
         & modif_ratqs,essai_convergence,iso_init,ridicule_rain,tnat, &
         & ridicule,ridicule_snow
-    USE isotopes_routines_mod, ONLY: iso_tritium
+    USE isotopes_routines_mod, ONLY: iso_tritium,dispatch,together
 #ifdef ISOVERIF
     USE isotopes_verif_mod, ONLY: errmax,errmaxrel, &
@@ -188 +191 @@
 !!!!!!!!!!!!!!!!!!  END "USE" for CPP keys !!!!!!!!!!!!!!!!!!!!!!
 
+USE physiqex_mod, ONLY : physiqex
 USE phys_local_var_mod, ONLY: phys_local_var_init, phys_local_var_end, &
        ! [Variables internes non sauvegardees de la physique]
@@ -193 +197 @@
        t_seri,q_seri,ql_seri,qs_seri,qbs_seri, &
        u_seri,v_seri,cf_seri,rvc_seri,tr_seri, &
+       rhcl, &        
+       qx_seri, & ! CR
        rhcl, &        
        ! Dynamic tendencies (diagnostics)
@@ -209 +215 @@
        !
        d_t_eva,d_q_eva,d_ql_eva,d_qi_eva, &
+       d_qx_eva, &
        d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc, &
        d_t_lscst,d_q_lscst, &
@@ -219 +226 @@
        d_ts, &
        !
-       d_t_bs,d_q_bs,d_qbs_bs, &
+       d_t_bsss,d_q_bsss,d_qbs_bsss, &
        !
 !       d_t_oli,d_u_oli,d_v_oli, &
@@ -247 +254 @@
        toplwai_aero,sollwai_aero,   &
        toplwad0_aero,sollwad0_aero, &
+       !pour Ecrad
+       topswad_aero_s2, solswad_aero_s2,   &
+       topswai_aero_s2, solswai_aero_s2,   &
+       topswad0_aero_s2, solswad0_aero_s2, &
+       topsw_aero_s2, topsw0_aero_s2,      &
+       solsw_aero_s2, solsw0_aero_s2,      &
+       topswcf_aero_s2, solswcf_aero_s2,   &
+       !LW diagnostics
+       toplwad_aero_s2, sollwad_aero_s2,   &
+       toplwai_aero_s2, sollwai_aero_s2,   &
+       toplwad0_aero_s2, sollwad0_aero_s2, &
        !
        topsw_aero,solsw_aero,       &
@@ -265 +283 @@
        toplwai_aerop, sollwai_aerop,   &
        toplwad0_aerop, sollwad0_aerop, &
+       !pour Ecrad
+       topswad_aero_s2, solswad_aero_s2,   &
+       topswai_aero_s2, solswai_aero_s2,   &
+       topswad0_aero_s2, solswad0_aero_s2, &
+       topsw_aero_s2, topsw0_aero_s2,      &
+       solsw_aero_s2, solsw0_aero_s2,      &
+       topswcf_aero_s2, solswcf_aero_s2,   &
+       !LW diagnostics
+       toplwad_aero_s2, sollwad_aero_s2,   &
+       toplwai_aero_s2, sollwai_aero_s2,   &
+       toplwad0_aero_s2, sollwad0_aero_s2, &
        !
        ptstar, pt0, slp, &
@@ -346 +375 @@
        !
        rneblsvol, &
-       pfraclr,pfracld, &
-       distcltop,temp_cltop, &
+       pfraclr, pfracld, cldfraliq, sigma2_icefracturb, mean_icefracturb,  &
+       distcltop, temp_cltop,  &
        !-- LSCP - condensation and ice supersaturation variables
        qsub, qissr, qcld, subfra, issrfra, gamma_cond, ratio_qi_qtot, &
@@ -384 +413 @@
 
 #ifdef ISO
-       USE phys_local_var_mod, ONLY: xt_seri,xtl_seri,xts_seri, &
+       USE phys_local_var_mod, ONLY: xt_seri,xtl_seri,xts_seri,xtbs_seri, &
        d_xt_eva,d_xtl_eva,d_xti_eva,           &
-       d_xt_dyn,d_xtl_dyn,d_xts_dyn,           &
+       d_xt_dyn,d_xtl_dyn,d_xts_dyn,d_xtbs_dyn, &
        d_xt_con, d_xt_wake,                    &
        d_xt_ajsb, d_xt_ajs,                    &
@@ -412 +441 @@
        USE phys_output_var_mod, ONLY: scdnc, cldncl, reffclwtop, lcc, reffclws, &
        reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra
+       USE output_physiqex_mod, ONLY: output_physiqex
 
 
@@ -556 +586 @@
     !
     ! indices de traceurs eau vapeur, liquide, glace, fraction nuageuse LS (optional), blowing snow (optional)
-    INTEGER,SAVE :: ivap, iliq, isol, ibs, icf, irvc
-!$OMP THREADPRIVATE(ivap, iliq, isol, ibs, icf, irvc)
-    !
+!    INTEGER,SAVE :: ivap, iliq, isol, irneb, ibs
+!!$OMP THREADPRIVATE(ivap, iliq, isol, irneb, ibs)
+! Camille Risi 25 juillet 2023: ivap,iliq,isol deja definis dans infotrac_phy. 
+! Et ils sont utiles ailleurs que dans physiq_mod (ex:
+! reevap -> je commente les 2 lignes au dessus et je laisse la definition
+! plutot dans infotrac_phy
+    INTEGER,SAVE :: irneb, ibs, icf,irvc
+!$OMP THREADPRIVATE(irneb, ibs, icf,irvc)
+!
     !
     ! Variables argument:
@@ -812 +848 @@
     real therm_tke_max0(klon)   ! TKE dans les thermiques au LCL 
     real env_tke_max0(klon)     ! TKE dans l'environnement au LCL 
+    INTEGER, SAVE :: iflag_thermcell_tke ! transtport TKE by thermals
+    !$OMP THREADPRIVATE(iflag_thermcell_tke)
 
 !JLD    !---D\'eclenchement stochastique
@@ -900 +938 @@
     EXTERNAL ajsec     ! ajustement sec
     EXTERNAL conlmd    ! convection (schema LMD)
-    !KE43
     EXTERNAL conema3  ! convect4.3
-    !AA 
-    ! JBM (3/14) fisrtilp_tr not loaded
-    ! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
-    !                          ! stockage des coefficients necessaires au
-    !                          ! lessivage OFF-LINE et ON-LINE
     EXTERNAL hgardfou  ! verifier les temperatures
     EXTERNAL nuage     ! calculer les proprietes radiatives
@@ -960 +992 @@
     REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
     !
-#ifdef INCA
-    REAL zxsnow_dummy(klon)
-#endif
     REAL zsav_tsol(klon)
     !
@@ -1068 +1097 @@
     !$OMP THREADPRIVATE(ok_bug_split_th)
 
+    ! Logical switch to a bug : modifying directly wake_deltat  by adding 
+    ! the (w) dry adjustment tendency to wake_deltat
+    LOGICAL, SAVE :: ok_bug_ajs_cv = .TRUE.
+    !$OMP THREADPRIVATE(ok_bug_ajs_cv)
     !
     !********************************************************
@@ -1205 +1238 @@
     REAL, DIMENSION(klon,klev)     :: mass_solu_aero_pi
     ! - " - (pre-industrial value)
+    REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer
 
     ! Parameters
@@ -1271 +1305 @@
     ! Declarations pour Simulateur COSP
     !============================================================
+    ! AI 10-22
+#ifdef CPP_COSP
+    include "ini_COSP.h"
+#endif
+#ifdef CPP_COSPV2
+    include "ini_COSP.h"
+#endif
     real :: mr_ozone(klon,klev), phicosp(klon,klev)
 
@@ -1346 +1387 @@
 
     REAL, dimension(klon,klev) :: t_env,q_env
+#ifdef ISO
+    real, dimension(ntraciso,klon,klev) ::  xt_env
+#endif
 
     REAL, dimension(klon) :: pr_et
@@ -1356 +1400 @@
     !AI namelist pour gerer le double appel de Ecrad
     CHARACTER(len=512) :: namelist_ecrad_file
+
+    !======================================================================!
+    ! Bifurcation vers un nouveau moniteur physique pour experimenter      !
+    ! des solutions et préparer le couplage avec la physique de MesoNH     !
+    ! 14 mai 2023                                                          !
+    !======================================================================!
+    if (debut) then                                                        !
+       iflag_physiq=0
+       call getin_p('iflag_physiq', iflag_physiq)                          !
+    endif                                                                  !
+    if ( iflag_physiq == 2 ) then
+#ifdef ISO
+       abort_message='isotopes pas encore dans physiqex'
+       CALL abort_physic(modname,abort_message,1)
+#endif
+       call physiqex (nlon,nlev, &                                         !
+       debut,lafin,pdtphys_, &                                             !
+       paprs,pplay,pphi,pphis,presnivs, &                                  !
+       u,v,rot,t,qx, &                                                     !
+       flxmass_w, &                                                        !
+       d_u, d_v, d_t, d_qx, d_ps)                                          !
+       return                                                              !
+    endif                                                                  !
+    !======================================================================!
+
 
     pi = 4. * ATAN(1.)
@@ -1372 +1441 @@
     phys_tstep=NINT(pdtphys)
     IF (.NOT. using_xios) missing_val=nf90_fill_real
-#ifdef CPP_XIOS
-! switch to XIOS LMDZ physics context 
-    IF (.NOT. debut .AND. is_omp_master) THEN
-       CALL wxios_set_context()
-       CALL xios_update_calendar(itap+1)
+
+    IF (using_xios) THEN
+      ! switch to XIOS LMDZ physics context 
+      IF (.NOT. debut .AND. is_omp_master) THEN
+        CALL wxios_set_context()
+        CALL xios_update_calendar(itap+1)
+      ENDIF
     ENDIF
-#endif
 
     !======================================================================
@@ -1384 +1454 @@
     ! Utilise notamment en 1D mais peut etre active egalement en 3D
     ! en imposant la valeur de igout.
-    !======================================================================d
+    !======================================================================
     IF (prt_level.ge.1) THEN
        igout=klon/2+1/klon
@@ -1441 +1511 @@
             read_climoz, &
             alp_offset)
+       CALL init_etat0_limit_unstruct
+       IF (.NOT. create_etat0_limit) CALL init_limit_read(days_elapsed)
        CALL phys_state_var_init(read_climoz)
        CALL phys_output_var_init
        IF (read_climoz>=1 .AND. create_etat0_limit .AND. grid_type==unstructured) & 
           CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
+
+#ifdef REPROBUS
+       CALL strataer_init
+       CALL strataer_emiss_init
+#endif
 
 #ifdef CPP_StratAer
@@ -1488 +1565 @@
 
         IF (ok_bs) THEN
+#ifdef ISO
           abort_message='blowing snow cannot be activated with water isotopes yet'
           CALL abort_physic(modname,abort_message, 1)
@@ -1497 +1575 @@
          ENDIF
         ENDIF
+
        Ncvpaseq1 = 0
        dnwd0=0.0
@@ -1538 +1617 @@
        tau_gl=86400.*tau_gl
        WRITE(lunout,*) 'debut physiq_mod tau_gl=',tau_gl
+       iflag_thermcell_tke=0
+       call getin_p('iflag_thermcell_tke', iflag_thermcell_tke)                          !
 
        CALL getin_p('iflag_alp_wk_cond', iflag_alp_wk_cond) 
@@ -1560 +1641 @@
        CALL getin_p('ok_bug_cv_trac',ok_bug_cv_trac)
        CALL getin_p('ok_bug_split_th',ok_bug_split_th)
+       CALL getin_p('ok_bug_ajs_cv',ok_bug_ajs_cv)
        fl_ebil = 0 ! by default, conservation diagnostics are desactivated
        CALL getin_p('fl_ebil',fl_ebil)
@@ -1596 +1678 @@
        CALL infocfields_init
 
+       !AI 08 2023
 #ifdef CPP_ECRAD
        ok_3Deffect=.false.
@@ -1875 +1958 @@
       IF (.NOT. create_etat0_limit) CALL init_readaerosolstrato(flag_aerosol_strat)  !! initialise aero strato from file for XIOS interpolation (unstructured_grid)
 
+      ! A.I : Initialisations pour le 1er passage a Cosp
+      if (ok_cosp) then
+
 #ifdef CPP_COSP
-      IF (ok_cosp) THEN
-!           DO k = 1, klev
-!             DO i = 1, klon
-!               phicosp(i,k) = pphi(i,k) + pphis(i)
-!             ENDDO
-!           ENDDO
+        CALL ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
+               zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
+               fiwc_cosp0,prfl_cosp0,psfl_cosp0,pmflxr_cosp0,pmflxs_cosp0, &
+               mr_ozone_cosp0,cldtau_cosp0,cldemi_cosp0,JrNt_cosp0)
+
         CALL phys_cosp(itap,phys_tstep,freq_cosp, &
                ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
                ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
                klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
-               JrNt,ref_liq,ref_ice, &
-               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
-               zu10m,zv10m,pphis, &
-               zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
-               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
-               prfl(:,1:klev),psfl(:,1:klev), &
-               pmflxr(:,1:klev),pmflxs(:,1:klev), &
-               mr_ozone,cldtau, cldemi)
-      ENDIF
-#endif
-
-#ifdef CPP_COSP2
-        IF (ok_cosp) THEN
-!           DO k = 1, klev
-!             DO i = 1, klon
-!               phicosp(i,k) = pphi(i,k) + pphis(i)
-!             ENDDO
-!           ENDDO
-          CALL phys_cosp2(itap,phys_tstep,freq_cosp, &
-               ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
-               ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
-               klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
-               JrNt,ref_liq,ref_ice, &
-               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
-               zu10m,zv10m,pphis, &
-               zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
-               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
-               prfl(:,1:klev),psfl(:,1:klev), &
-               pmflxr(:,1:klev),pmflxs(:,1:klev), &
-               mr_ozone,cldtau, cldemi)
-       ENDIF
+               JrNt_cosp0,ref_liq_cosp0,ref_ice_cosp0, &
+               pctsrf_cosp0, &
+               zu10m_cosp0,zv10m_cosp0,pphis, &
+               pphi,paprs(:,1:klev),pplay,zxtsol_cosp0,t, &
+               qx(:,:,ivap),zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0,fiwc_cosp0, &
+               prfl_cosp0(:,1:klev),psfl_cosp0(:,1:klev), &
+               pmflxr_cosp0(:,1:klev),pmflxs_cosp0(:,1:klev), &
+               mr_ozone_cosp0,cldtau_cosp0, cldemi_cosp0)
 #endif
 
 #ifdef CPP_COSPV2
-        IF (ok_cosp) THEN
-           DO k = 1, klev
-             DO i = 1, klon
-               phicosp(i,k) = pphi(i,k) + pphis(i)
-             ENDDO
-           ENDDO
+          CALL ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
+               zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
+               fiwc_cosp0,prfl_cosp0,psfl_cosp0,pmflxr_cosp0,pmflxs_cosp0, &
+               mr_ozone_cosp0,cldtau_cosp0,cldemi_cosp0,JrNt_cosp0)
+
           CALL lmdz_cosp_interface(itap,phys_tstep,freq_cosp, &
                ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
                ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
                klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
-               JrNt,ref_liq,ref_ice, &
-               pctsrf(:,is_ter)+pctsrf(:,is_lic), &
-               zu10m,zv10m,pphis, &
-               phicosp,paprs(:,1:klev),pplay,zxtsol,t_seri, &
-               qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
-               prfl(:,1:klev),psfl(:,1:klev), &
-               pmflxr(:,1:klev),pmflxs(:,1:klev), &
-               mr_ozone,cldtau, cldemi)
-       ENDIF
-#endif
+               JrNt_cosp0,ref_liq_cosp0,ref_ice_cosp0, &
+               pctsrf_cosp0, &
+               zu10m_cosp0,zv10m_cosp0,pphis, &
+               pphi,paprs(:,1:klev),pplay,zxtsol_cosp0,t, &
+               qx(:,:,ivap),zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0,fiwc_cosp0, &
+               prfl_cosp0(:,1:klev),psfl_cosp0(:,1:klev), &
+               pmflxr_cosp0(:,1:klev),pmflxs_cosp0(:,1:klev), &
+               mr_ozone_cosp0,cldtau_cosp0, cldemi_cosp0)
+#endif
+
+      endif !ok_cosp
 
        !
@@ -2014 +2076 @@
 
 
-#ifdef CPP_XIOS
-       IF (is_omp_master) CALL xios_update_calendar(1)
-#endif
+       IF (using_xios) THEN
+         IF (is_omp_master) CALL xios_update_calendar(1)
+       ENDIF
+       
        IF(read_climoz>=1 .AND. create_etat0_limit) CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
        CALL create_etat0_limit_unstruct
@@ -2213 +2276 @@
        ENDIF
 
-      IF (using_xios) THEN 
-! Need to put this initialisation after phyetat0 as in the coupled model the XIOS context is only
-! initialised at that moment
-       ! Get "missing_val" value from XML files (from temperature variable)
-        IF (is_omp_master) CALL xios_get_field_attr("temp",default_value=missing_val)
-        CALL bcast_omp(missing_val)
-       
+       IF (using_xios) THEN    
+         ! Need to put this initialisation after phyetat0 as in the coupled model the XIOS context is only
+         ! initialised at that moment
+         ! Get "missing_val" value from XML files (from temperature variable)
+         IF (is_omp_master) CALL xios_get_field_attr("temp",default_value=missing_val)
+         CALL bcast_omp(missing_val)
        ! 
        ! Now we activate some double radiation call flags only if some
        ! diagnostics are requested, otherwise there is no point in doing this
-       IF (is_master) THEN
-         !--setting up swaero_diag to TRUE in XIOS case 
-         IF (xios_field_is_active("topswad").OR.xios_field_is_active("topswad0").OR. & 
-            xios_field_is_active("solswad").OR.xios_field_is_active("solswad0").OR. & 
-            xios_field_is_active("topswai").OR.xios_field_is_active("solswai").OR.  & 
-              (iflag_rrtm==1.AND.(xios_field_is_active("toplwad").OR.xios_field_is_active("toplwad0").OR. & 
-                                  xios_field_is_active("sollwad").OR.xios_field_is_active("sollwad0"))))  & 
-            !!!--for now these fields are not in the XML files so they are omitted 
-            !!!  xios_field_is_active("toplwai").OR.xios_field_is_active("sollwai") !))) & 
-            swaero_diag=.TRUE. 
+         IF (is_master) THEN
+           !--setting up swaero_diag to TRUE in XIOS case 
+           IF (xios_field_is_active("topswad").OR.xios_field_is_active("topswad0").OR. & 
+              xios_field_is_active("solswad").OR.xios_field_is_active("solswad0").OR. & 
+              xios_field_is_active("topswai").OR.xios_field_is_active("solswai").OR.  & 
+                (iflag_rrtm==1.AND.(xios_field_is_active("toplwad").OR.xios_field_is_active("toplwad0").OR. & 
+                                    xios_field_is_active("sollwad").OR.xios_field_is_active("sollwad0"))))  & 
+              !!!--for now these fields are not in the XML files so they are omitted 
+              !!!  xios_field_is_active("toplwai").OR.xios_field_is_active("sollwai") !))) & 
+              swaero_diag=.TRUE. 
  
-         !--setting up swaerofree_diag to TRUE in XIOS case 
-         IF (xios_field_is_active("SWdnSFCcleanclr").OR.xios_field_is_active("SWupSFCcleanclr").OR. &
-            xios_field_is_active("SWupTOAcleanclr").OR.xios_field_is_active("rsucsaf").OR.   &
-            xios_field_is_active("rsdcsaf") .OR. xios_field_is_active("LWdnSFCcleanclr").OR. &
-            xios_field_is_active("LWupTOAcleanclr")) &
-            swaerofree_diag=.TRUE. 
+           !--setting up swaerofree_diag to TRUE in XIOS case 
+           IF (xios_field_is_active("SWdnSFCcleanclr").OR.xios_field_is_active("SWupSFCcleanclr").OR. &
+              xios_field_is_active("SWupTOAcleanclr").OR.xios_field_is_active("rsucsaf").OR.   &
+              xios_field_is_active("rsdcsaf") .OR. xios_field_is_active("LWdnSFCcleanclr").OR. &
+              xios_field_is_active("LWupTOAcleanclr")) &
+              swaerofree_diag=.TRUE. 
  
-         !--setting up dryaod_diag to TRUE in XIOS case 
-         DO naero = 1, naero_tot-1
-          IF (xios_field_is_active("dryod550_"//name_aero_tau(naero))) dryaod_diag=.TRUE. 
-         ENDDO
-         !
-         !--setting up ok_4xCO2atm to TRUE in XIOS case 
-         IF (xios_field_is_active("rsut4co2").OR.xios_field_is_active("rlut4co2").OR. & 
-            xios_field_is_active("rsutcs4co2").OR.xios_field_is_active("rlutcs4co2").OR. &
-            xios_field_is_active("rsu4co2").OR.xios_field_is_active("rsucs4co2").OR. &
-            xios_field_is_active("rsd4co2").OR.xios_field_is_active("rsdcs4co2").OR. &
-            xios_field_is_active("rlu4co2").OR.xios_field_is_active("rlucs4co2").OR. &
-            xios_field_is_active("rld4co2").OR.xios_field_is_active("rldcs4co2")) &
-            ok_4xCO2atm=.TRUE. 
-       ENDIF
-       !$OMP BARRIER
-       CALL bcast(swaero_diag)
-       CALL bcast(swaerofree_diag)
-       CALL bcast(dryaod_diag)
-       CALL bcast(ok_4xCO2atm)
-
-     ENDIF !using_xios 
-
+           !--setting up dryaod_diag to TRUE in XIOS case 
+           DO naero = 1, naero_tot-1
+             IF (xios_field_is_active("dryod550_"//name_aero_tau(naero))) dryaod_diag=.TRUE. 
+           ENDDO
+           !
+          !--setting up ok_4xCO2atm to TRUE in XIOS case 
+           IF (xios_field_is_active("rsut4co2").OR.xios_field_is_active("rlut4co2").OR. & 
+              xios_field_is_active("rsutcs4co2").OR.xios_field_is_active("rlutcs4co2").OR. &
+              xios_field_is_active("rsu4co2").OR.xios_field_is_active("rsucs4co2").OR. &
+              xios_field_is_active("rsd4co2").OR.xios_field_is_active("rsdcs4co2").OR. &
+              xios_field_is_active("rlu4co2").OR.xios_field_is_active("rlucs4co2").OR. &
+              xios_field_is_active("rld4co2").OR.xios_field_is_active("rldcs4co2")) &
+              ok_4xCO2atm=.TRUE. 
+           ENDIF
+           !$OMP BARRIER
+           CALL bcast(swaero_diag)
+           CALL bcast(swaerofree_diag)
+           CALL bcast(dryaod_diag)
+           CALL bcast(ok_4xCO2atm)
+         ENDIF !using_xios
        !
        CALL printflag( tabcntr0,radpas,ok_journe, &
@@ -2549 +2609 @@
           u_seri(i,k)  = u(i,k)
           v_seri(i,k)  = v(i,k)
+          qx_seri(i,k,:)  = qx(i,k,:)
           q_seri(i,k)  = qx(i,k,ivap)
           ql_seri(i,k) = qx(i,k,iliq)
@@ -2590 +2651 @@
       DO k = 1, klev
        DO i = 1, klon
+          xtbs_seri(ixt,i,k) = 0.
           xt_seri(ixt,i,k)  = qx(i,k,iqIsoPha(ixt,ivap))
           xtl_seri(ixt,i,k) = qx(i,k,iqIsoPha(ixt,iliq))
@@ -2610 +2672 @@
     qql1(:)=0.0
     DO k = 1, klev
-      qql1(:)=qql1(:)+(q_seri(:,k)+ql_seri(:,k)+qs_seri(:,k)+qbs_seri(:,k))*zmasse(:,k)
+      qql1(:)=qql1(:)+(q_seri(:,k)+ql_seri(:,k))*zmasse(:,k)
+      IF (nqo >= 3) THEN
+        qql1(:)=qql1(:)+qs_seri(:,k)*zmasse(:,k)
+      ENDIF
+      IF (ok_bs) THEN
+        qql1(:)=qql1(:)+qbs_seri(:,k)*zmasse(:,k)
+      ENDIF
     ENDDO
 #ifdef ISO
-#ifdef ISOVERIF
-        write(*,*) 'physiq tmp 1913'
-#endif
-    do ixt=1,ntraciso
+    DO ixt=1,ntraciso
     xtql1(ixt,:)=0.0
     DO k = 1, klev
-      xtql1(ixt,:)=xtql1(ixt,:)+(xt_seri(ixt,:,k)+xtl_seri(ixt,:,k)+xts_seri(ixt,:,k))*zmasse(:,k)
-    ENDDO
-    enddo !do ixt=1,ntraciso
+      xtql1(ixt,:)=xtql1(ixt,:)+(xt_seri(ixt,:,k)+xtl_seri(ixt,:,k))*zmasse(:,k)
+      IF (nqo >= 3) THEN
+        xtql1(ixt,:)=xtql1(ixt,:)+xts_seri(ixt,:,k)*zmasse(:,k)
+      ENDIF
+      IF (ok_bs) THEN
+        xtql1(ixt,:)=xtql1(ixt,:)+xtbs_seri(ixt,:,k)*zmasse(:,k)
+      ENDIF
+    ENDDO !DO k = 1, klev
+    ENDDO !DO ixt=1,ntraciso
 #endif
     ENDIF
@@ -2633 +2704 @@
          IF(.NOT.tracers(iq)%isInPhysics) CYCLE
          itr = itr+1
-!#ifdef ISOVERIF
-!         write(*,*) 'physiq 1973: itr,iq=',itr,iq
-!         write(*,*) 'qx(1,1,iq)=',qx(1,1,iq)
-!#endif
-         DO  k = 1, klev
+          DO  k = 1, klev
              DO  i = 1, klon
                 tr_seri(i,k,itr) = qx(i,k,iq)
@@ -2752 +2819 @@
               d_xts_dyn(ixt,i,k) =  &
      &           (xts_seri(ixt,i,k)-xts_ancien(ixt,i,k))/phys_tstep
+              d_xtbs_dyn(ixt,i,k) =  &
+     &           (xtbs_seri(ixt,i,k)-xtbs_ancien(ixt,i,k))/phys_tstep
             enddo ! do ixt=1,ntraciso
          ENDDO
@@ -2765 +2834 @@
            call iso_verif_noNaN(d_xtl_dyn(ixt,i,k),'physiq 2220d')
            call iso_verif_noNaN(d_xts_dyn(ixt,i,k),'physiq 2220e')
+           call iso_verif_noNaN(d_xtbs_dyn(ixt,i,k),'physiq 2220f')
            enddo ! do ixt=1,ntraciso
          enddo
@@ -2848 +2918 @@
        ! !! RomP <<<
        ancien_ok = .TRUE.
+#ifdef ISO
+       d_xtbs_dyn(:,:,:)=0.0
+#endif
     ENDIF
     !
@@ -2986 +3059 @@
     ! Re-evaporer l'eau liquide nuageuse
     !
-     CALL reevap (klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
-   &         d_t_eva,d_q_eva,d_ql_eva,d_qi_eva &
-#ifdef ISO
-             ,xt_seri,xtl_seri,xts_seri,d_xt_eva,d_xtl_eva,d_xti_eva &
-#endif
-   &     )
+     CALL reevap (klon,klev,iflag_ice_thermo,t_seri,qx_seri, &
+   &         d_t_eva,d_qx_eva)
+
+     call dispatch(klon,klev,qx_seri,q_seri,xt_seri,ql_seri,xtl_seri,qs_seri,xts_seri)
+     call dispatch(klon,klev,d_qx_eva,d_q_eva,d_xt_eva,d_ql_eva,d_xtl_eva,d_qi_eva,d_xti_eva)
+
+
+#ifdef ISO
+#ifdef ISOVERIF
+ DO k = 1, klev 
+     DO i = 1, klon
+      do ixt=1,ntraciso
+      call iso_verif_noNaN(xt_seri(ixt,i,k), &
+     &     'reevap 2417: apres evap tot')
+      enddo
+      if (iso_eau.gt.0) then
+              call iso_verif_egalite_choix( &
+     &           xt_seri(iso_eau,i,k),q_seri(i,k), &
+     &          'reevap 1891, après réévap totale',errmax,errmaxrel)
+              call iso_verif_egalite_choix( &
+     &           xtl_seri(iso_eau,i,k),ql_seri(i,k), &
+     &          'reevap 2209, après réévap totale',errmax,errmaxrel)
+              call iso_verif_egalite_choix( &
+     &           xts_seri(iso_eau,i,k),qs_seri(i,k), &
+     &          'reevap 2209b, après réévap totale',errmax,errmaxrel)
+       endif !if (iso_eau.gt.0) then
+     
+      if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then  
+            if (q_seri(i,k).gt.ridicule) then  
+               if (iso_verif_o18_aberrant_nostop( &
+     &              xt_seri(iso_HDO,i,k)/q_seri(i,k), &
+     &              xt_seri(iso_O18,i,k)/q_seri(i,k), &
+     &              'reevap 2408: apres reevap totale').eq.1) then
+                  write(*,*) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)                       
+                  stop
+              endif !  if (iso_verif_o18_aberrant_nostop
+            endif !if (q_seri(i,k).gt.errmax) then   
+        endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then        
+#ifdef ISOTRAC      
+             call iso_verif_traceur(xt_seri(1,i,k), &
+     &           'reevap 2165c')
+             call iso_verif_traceur_pbidouille(xt_seri(1,i,k), &
+     &           'reevap 2165d')
+#endif
+       ENDDO
+    ENDDO               
+#endif                  
+#endif
+
 
      CALL add_phys_tend &
@@ -3123 +3239 @@
     ! Calcul de l'humidite de saturation au niveau du sol
 
+! Tests Fredho, instensibilite au pas de temps -------------------------------
+! A detruire en 2024 une fois les tests documentes et les choix faits        !
+! Conservation des variables avant l'appel à l a diffusion pour les tehrmic  !
+    if (iflag_thermals_tenv / 10 == 1 ) then                                 !
+        do k=1,klev                                                          !
+           do i=1,klon                                                       !
+              t_env(i,k)=t_seri(i,k)                                         !
+              q_env(i,k)=q_seri(i,k)   
+#ifdef ISO
+              do ixt=1,ntraciso
+                xt_env(ixt,i,k)=xt_seri(ixt,i,k)
+              enddo
+#endif
+           enddo                                                             !
+        enddo                                                                !
+    else if (iflag_thermals_tenv / 10 == 2 ) then                            !
+        do k=1,klev                                                          !
+           do i=1,klon                                                       !
+              t_env(i,k)=t_seri(i,k)                                         !
+           enddo                                                             !
+        enddo                                                                !
+    endif                                                                    !
+! Tests Fredho, instensibilite au pas de temps -------------------------------
 
 
@@ -3311 +3450 @@
           d_deltaq_vdf(:,:) = d_q_vdf_w(:,:)-d_q_vdf_x(:,:)
           CALL add_wake_tend &
-             (d_deltat_vdf, d_deltaq_vdf, dsig0, ddens0, ddens0, wkoccur1, 'vdf', abortphy &
+             (d_deltat_vdf, d_deltaq_vdf, dsig0, dsig0, ddens0, ddens0, wkoccur1, 'vdf', abortphy &
 #ifdef ISO
                ,d_deltaxt_vdf &
@@ -3344 +3483 @@
      &   )
        ENDIF
-#ifdef ISOVERIF
-        write(*,*) 'physiq tmp 2736'
-#endif
-
        CALL prt_enerbil('vdf',itap)
+
        !--------------------------------------------------------------------
 
@@ -3403 +3539 @@
     ! Blowing snow sublimation and sedimentation
 
-    d_t_bs(:,:)=0.
-    d_q_bs(:,:)=0.
-    d_qbs_bs(:,:)=0.
+    d_t_bsss(:,:)=0.
+    d_q_bsss(:,:)=0.
+    d_qbs_bsss(:,:)=0.
     bsfl(:,:)=0.
     bs_fall(:)=0.
@@ -3411 +3547 @@
 
      CALL call_blowing_snow_sublim_sedim(klon,klev,phys_tstep,t_seri,q_seri,qbs_seri,pplay,paprs, &
-                                        d_t_bs,d_q_bs,d_qbs_bs,bsfl,bs_fall)
+                                        d_t_bsss,d_q_bsss,d_qbs_bsss,bsfl,bs_fall)
 
      CALL add_phys_tend &
-               (du0,dv0,d_t_bs,d_q_bs,dql0,dqi0,d_qbs_bs,paprs,&
+               (du0,dv0,d_t_bsss,d_q_bsss,dql0,dqi0,d_qbs_bsss,paprs,&
                'bs',abortphy,flag_inhib_tend,itap,0  &
 #ifdef ISO                                       
@@ -3713 +3849 @@
                 ENDDO
              ENDDO
-             IF (iflag_adjwk == 2) THEN
+             IF (iflag_adjwk == 2 .AND. OK_bug_ajs_cv) THEN
                CALL add_wake_tend &
-                 (d_deltat_ajs_cv, d_deltaq_ajs_cv, dsig0, ddens0, ddens0, wkoccur1, 'ajs_cv', abortphy &
+                 (d_deltat_ajs_cv, d_deltaq_ajs_cv, dsig0, dsig0, ddens0, ddens0, wkoccur1, 'ajs_cv', abortphy &
 #ifdef ISO
                       ,d_deltaxt_ajs_cv  &
 #endif
                  ) 
-             ENDIF  ! (iflag_adjwk == 2)
+             ENDIF  ! (iflag_adjwk == 2 .AND. OK_bug_ajs_cv)
           ENDIF  ! (iflag_adjwk >= 1)
        ENDIF ! (iflag_wake>=1)
@@ -4424 +4560 @@
        !  ====
        IF (prt_level>9) WRITE(lunout,*)'pas de convection seche'
+       WRITE(lunout,*) 'WARNING : running without dry convection. Somme intermediate variables are not properly defined in physiq_mod.F90'
+       ! Reprendre proprement les initialisation ci dessouds si on veut vraiment utiliser l'option (FH)
+          fraca(:,:)=0.
+          fm_therm(:,:)=0.
+          ztv(:,:)=t_seri(:,:)
+          zqasc(:,:)=q_seri(:,:)
+          ztla(:,:)=0.
+          zthl(:,:)=0.
+          zpspsk(:,:)=(pplay(:,:)/100000.)**RKAPPA
 
 
@@ -4515 +4660 @@
 
        IF (iflag_thermals>=1) THEN
+
+! Tests Fredho, instensibilite au pas de temps -------------------------------
+! A detruire en 2024 une fois les tests documentes et les choix faits        !
+          if (iflag_thermals_tenv /10 == 0 ) then                            !
+            do k=1,klev                                                      !
+               do i=1,klon                                                   !
+                  t_env(i,k)=t_seri(i,k)                                     !
+                  q_env(i,k)=q_seri(i,k)                                     !
+#ifdef ISO
+                  do ixt=1,ntraciso
+                        xt_env(ixt,i,k)=xt_seri(ixt,i,k)
+                  enddo
+#endif
+               enddo                                                         !
+            enddo                                                            !
+          else if (iflag_thermals_tenv / 10 == 2 ) then                      !
+            do k=1,klev                                                      !
+               do i=1,klon                                                   !
+                  q_env(i,k)=q_seri(i,k)                                     !
+#ifdef ISO
+                  do ixt=1,ntraciso
+                        xt_env(ixt,i,k)=xt_seri(ixt,i,k)
+                  enddo
+#endif
+               enddo                                                         !
+            enddo                                                            !
+          else if (iflag_thermals_tenv / 10 == 3 ) then                      !
+            do k=1,klev                                                      !
+               do i=1,klon                                                   !
+                  t_env(i,k)=t(i,k)                                          !
+                  q_env(i,k)=qx(i,k,1)                                       !
+#ifdef ISO
+                  do ixt=1,ntraciso
+                        xt_env(ixt,i,k)=xt_seri(ixt,i,k)
+                  enddo
+#endif
+               enddo                                                         !
+            enddo                                                            !
+          endif                                                              !
+! Tests Fredho, instensibilite au pas de temps ------------------------------
+
           !jyg<
 !!       IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN
@@ -4523 +4709 @@
                    t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k)
                    q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k)
+                   t_env(i,k)   = t_env(i,k) - wake_s(i)*wake_deltat(i,k)
+                   q_env(i,k)   = q_env(i,k) - wake_s(i)*wake_deltaq(i,k)
                    u_therm(i,k) = u_seri(i,k)
                    v_therm(i,k) = v_seri(i,k)
@@ -4528 +4716 @@
                    do ixt=1,ntraciso
                      xt_therm(ixt,i,k) = xt_seri(ixt,i,k) - wake_s(i)*wake_deltaxt(ixt,i,k)
+                     xt_env(ixt,i,k) = xt_env(ixt,i,k) - wake_s(i)*wake_deltaxt(ixt,i,k)
                    enddo !do ixt=1,ntraciso
 #endif
@@ -4570 +4759 @@
                ,pplay,paprs,pphi,weak_inversion &
                         ! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & !jyg
-               ,u_therm,v_therm,t_therm,q_therm,t_therm,q_therm,zqsat,debut &  !jyg
+               ,u_therm,v_therm,t_therm,q_therm,t_env,q_env,zqsat,debut &  !jyg
                ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs &
                ,fm_therm,entr_therm,detr_therm &
@@ -4589 +4778 @@
                ,zqla,ztva &
 #ifdef ISO         
-     &      ,xt_therm,d_xt_ajs &
+     &      ,xt_env,d_xt_ajs &
 #ifdef DIAGISO         
      &      ,q_the,xt_the &
@@ -4624 +4813 @@
              IF (ok_bug_split_th) THEN
                CALL add_wake_tend &
-                   (d_deltat_the, d_deltaq_the, dsig0, ddens0, ddens0, wkoccur1, 'the', abortphy &
+                   (d_deltat_the, d_deltaq_the, dsig0, dsig0, ddens0, ddens0, wkoccur1, 'the', abortphy &
 #ifdef ISO
                    ,d_deltaxt_the &
@@ -4631 +4820 @@
              ELSE
                CALL add_wake_tend &
-                   (d_deltat_the, d_deltaq_the, dsig0, ddens0, ddens0, wake_k, 'the', abortphy &
+                   (d_deltat_the, d_deltaq_the, dsig0, dsig0, ddens0, ddens0, wake_k, 'the', abortphy &
 #ifdef ISO
                    ,d_deltaxt_the &
@@ -4660 +4849 @@
           ! Transport de la TKE par les panaches thermiques.
           ! FH : 2010/02/01
-          !     if (iflag_pbl.eq.10) then
-          !     call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm,
-          !    s           rg,paprs,pbl_tke)
-          !     endif
+               if (iflag_thermcell_tke==1) then
+               call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm,rg,paprs,pbl_tke)
+               endif
           ! -------------------------------------------------------------------
 
@@ -4902 +5090 @@
 
     CALL lscp(klon,klev,phys_tstep,missing_val,paprs,pplay, &
-         t_seri, q_seri,ptconv,ratqs, &
+         t_seri, q_seri,qs_ancien,ptconv,ratqs, &
          d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, rneblsvol, & 
-         pfraclr,pfracld, &
+         pfraclr, pfracld, cldfraliq, sigma2_icefracturb, mean_icefracturb,  &
          radocond, picefra, rain_lsc, snow_lsc, &
          frac_impa, frac_nucl, beta_prec_fisrt, &
          prfl, psfl, rhcl,  &
          zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, &
-         iflag_ice_thermo, distcltop, temp_cltop, cell_area, &
-         cf_seri, rvc_seri, u_seri, v_seri, pbl_eps(:,:,is_ave), &
+         iflag_ice_thermo, distcltop, temp_cltop, 
+         pbl_tke(:,:,is_ave), pbl_eps(:,:,is_ave), &
+         cell_area, &
+         cf_seri, rvc_seri, u_seri, v_seri, &
          qsub, qissr, qcld, subfra, issrfra, gamma_cond, ratio_qi_qtot, &
          dcf_sub, dcf_con, dcf_mix, dqi_adj, dqi_sub, dqi_con, dqi_mix, &
@@ -4923 +5113 @@
     ELSE
 
+    ! Camille Risi mai 2024: on ne met pas à jour ici pour ne pas s'mbêter à modifier fisrtilp
     CALL fisrtilp(phys_tstep,paprs,pplay, &
          t_seri, q_seri,ptconv,ratqs, &
@@ -5522 +5713 @@
                      tausum_aero, tau3d_aero)
              ENDIF
-          ELSE                       ! RRTM radiation
+          ELSE IF (iflag_rrtm .EQ.1) THEN  ! RRTM radiation
              IF (aerosol_couple .AND. config_inca == 'aero' ) THEN
                 abort_message='config_inca=aero et rrtm=1 impossible'
@@ -5588 +5779 @@
                 !
              ENDIF
+          ELSE IF (iflag_rrtm .EQ.2) THEN    ! ecrad RADIATION
+#ifdef CPP_ECRAD
+             !--climatologies or INCA aerosols
+             CALL readaerosol_optic_ecrad( debut, aerosol_couple, ok_alw, ok_volcan, &
+                  flag_aerosol, flag_bc_internal_mixture, itap, jD_cur-jD_ref, &
+                  pdtphys, pplay, paprs, t_seri, rhcl, presnivs,  &
+                  tr_seri, mass_solu_aero, mass_solu_aero_pi, m_allaer)
+#else
+                abort_message='You should compile with -rad ecrad if running with iflag_rrtm=2'
+                CALL abort_physic(modname,abort_message,1)
+#endif
           ENDIF
        ELSE   !--flag_aerosol = 0 
@@ -5828 +6030 @@
                ! Rajoute par OB pour RRTM
                tau_aero_lw_rrtm, & 
-               cldtaupirad, &
+               cldtaupirad, m_allaer, &
 !              zqsat, flwcrad, fiwcrad, &
                zqsat, flwc, fiwc, &
@@ -5907 +6109 @@
                                 ! Rajoute par OB pour RRTM
                      tau_aero_lw_rrtm, &
-                     cldtaupi, &
+                     cldtaupi, m_allaer, &
 !                    zqsat, flwcrad, fiwcrad, &
                      zqsat, flwc, fiwc, &
@@ -5934 +6136 @@
                      cloud_cover_sw)
           ENDIF !ok_4xCO2atm
+
+! A.I aout 2023
+! Effet 3D des nuages Ecrad
+! a passer : nom du ficher namelist et cles ok_3Deffect
+! a declarer comme iflag_rrtm et a lire dans physiq.def
+#ifdef CPP_ECRAD
+          IF (ok_3Deffect) then
+!                print*,'ok_3Deffect = ',ok_3Deffect  
+                namelist_ecrad_file='namelist_ecrad_s2'
+                CALL radlwsw &
+                     (debut, dist, rmu0, fract,  &
+                     paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, &
+                     t_seri,q_seri,wo, &
+                     cldfrarad, cldemirad, cldtaurad, &
+                     ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie,  ok_volcan, flag_volc_surfstrat, &
+                     flag_aerosol, flag_aerosol_strat, flag_aer_feedback, &
+                     tau_aero, piz_aero, cg_aero, &
+                     tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
+                     tau_aero_lw_rrtm, &
+                     cldtaupi, &
+                     zqsat, flwc, fiwc, &
+                     ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
+                     namelist_ecrad_file, &
+! A modifier              
+                     heat_s2,heat0_s2,cool_s2,cool0_s2,albpla_s2, &
+                     heat_volc,cool_volc, &
+                     topsw_s2,toplw_s2,solsw_s2,solswfdiff_s2,sollw_s2, &
+                     sollwdown_s2, &
+                     topsw0_s2,toplw0_s2,solsw0_s2,sollw0_s2, &
+                     lwdnc0_s2, lwdn0_s2, lwdn_s2, lwupc0_s2, lwup0_s2, lwup_s2,  &
+                     swdnc0_s2, swdn0_s2, swdn_s2, swupc0_s2, swup0_s2, swup_s2, &
+                     topswad_aero_s2, solswad_aero_s2, &
+                     topswai_aero_s2, solswai_aero_s2, &
+                     topswad0_aero_s2, solswad0_aero_s2, &
+                     topsw_aero_s2, topsw0_aero_s2, &
+                     solsw_aero_s2, solsw0_aero_s2, &
+                     topswcf_aero_s2, solswcf_aero_s2, &
+                                !-C. Kleinschmitt for LW diagnostics
+                     toplwad_aero_s2, sollwad_aero_s2,&
+                     toplwai_aero_s2, sollwai_aero_s2, &
+                     toplwad0_aero_s2, sollwad0_aero_s2,&
+                                !-end
+                     ZLWFT0_i, ZFLDN0, ZFLUP0, &
+                     ZSWFT0_i, ZFSDN0, ZFSUP0, &
+                     cloud_cover_sw_s2)
+          ENDIF ! ok_3Deffect
+#endif
+
        ENDIF ! aerosol_couple
        itaprad = 0
@@ -6157 +6407 @@
        d_t_hin(:, :)=0.
        CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, &
-            dqi0, dqbs0,paprs, 'hin', abortphy,flag_inhib_tend,itap,0 &
+            dqi0, dqbs0, paprs, 'hin', abortphy,flag_inhib_tend,itap,0 &
 #ifdef ISO
      &    ,dxt0,dxtl0,dxti0 &
@@ -6280 +6530 @@
        
        SELECT CASE(flag_emit)
-       CASE(1) ! emission volc H2O dans LMDZ
+       CASE(1) ! emission volc H2O in LMDZ
           DO ieru=1, nErupt
              IF (year_cur==year_emit_vol(ieru).AND.&
@@ -6288 +6538 @@
                 
                 IF(flag_verbose_strataer) print *,'IN physiq_mod: date=',year_cur,mth_cur,day_cur
-                ! initialisation tendance q emission
+                ! initialisation of q tendency emission
                 d_q_emiss(:,:)=0.
                 ! daily injection mass emission - NL
@@ -6295 +6545 @@
                 !
                 CALL STRATEMIT(pdtphys,pdtphys,latitude_deg,longitude_deg,t_seri,&
-                     pplay,paprs,tr_seri,&
-                     m_H2O_emiss_vol_daily,&
-                     xlat_min_vol(ieru),xlat_max_vol(ieru),&
-                     xlon_min_vol(ieru),xlon_max_vol(ieru),&
-                     altemiss_vol(ieru),&
-                     sigma_alt_vol(ieru),1,&
-                     1,nAerErupt+1,0)
+                    pplay,paprs,tr_seri,&
+                    m_H2O_emiss_vol_daily,&
+                    xlat_min_vol(ieru),xlat_max_vol(ieru),&
+                    xlon_min_vol(ieru),xlon_max_vol(ieru),&
+                    altemiss_vol(ieru),sigma_alt_vol(ieru),1,1.,&
+                    nAerErupt+1,0)
                 
                 IF(flag_verbose_strataer) print *,'IN physiq_mod: min max d_q_emiss=',&
@@ -6315 +6564 @@
     ENDIF
 #endif
-
 
 !===============================================================
@@ -6754 +7002 @@
     t_seri(:,:)=t_seri(:,:)+d_t_ec(:,:)
 
-    !=======================================================================
-    !   SORTIES
-    !=======================================================================
-    !
-    !IM initialisation + calculs divers diag AMIP2
-    !
-    include "calcul_divers.h"
-    !
-    !IM Interpolation sur les niveaux de pression du NMC
-    !   -------------------------------------------------
-    !
-    include "calcul_STDlev.h"
-    !
-    ! slp sea level pressure derived from Arpege-IFS : CALL ctstar + CALL pppmer
-    CALL diag_slp(klon,t_seri,paprs,pplay,pphis,ptstar,pt0,slp)
-    !
+    !==================================================================
+    !--OB water mass fixer for the physics
+    !--water profiles are corrected to force mass conservation of water
+    !--currently flag is turned off
+    !==================================================================
+    IF (mass_fixer) THEN
+#ifdef ISO
+      CALL abort_gcm('physiq 6936','isos pas prevus dans le mass fixer',1)
+      ! Camille Risi mai 2024: on attend d'avoir la 4e dimension qui rendra tout plus simple.
+#endif
+    qql2(:)=0.0
+    DO k = 1, klev
+      qql2(:)=qql2(:)+(q_seri(:,k)+ql_seri(:,k))*zmasse(:,k)
+      IF (nqo >= 3) THEN
+        qql2(:)=qql2(:)+qs_seri(:,k)*zmasse(:,k)
+      ENDIF
+      IF (ok_bs) THEN
+        qql2(:)=qql2(:)+qbs_seri(:,k)*zmasse(:,k)
+      ENDIF
+    ENDDO
+
+#ifdef CPP_StratAer
+    IF (ok_qemiss) THEN
+       DO k = 1, klev
+          qql1(:) = qql1(:)+d_q_emiss(:,k)*zmasse(:,k)
+       ENDDO
+    ENDIF
+#endif
+    IF (ok_qch4) THEN
+       DO k = 1, klev
+          qql1(:) = qql1(:)+d_q_ch4_dtime(:,k)*zmasse(:,k)
+       ENDDO
+    ENDIF
+    
+    DO i = 1, klon
+      !--compute ratio of what q+ql should be with conservation to what it is
+      IF (ok_bs) THEN
+        corrqql=(qql1(i)+(evap(i)-rain_fall(i)-snow_fall(i)-bs_fall(i))*pdtphys)/qql2(i)
+      ELSE
+        corrqql=(qql1(i)+(evap(i)-rain_fall(i)-snow_fall(i))*pdtphys)/qql2(i)
+      ENDIF
+      DO k = 1, klev
+        q_seri(i,k) =q_seri(i,k)*corrqql
+        ql_seri(i,k)=ql_seri(i,k)*corrqql
+        IF (nqo >= 3) THEN
+          qs_seri(i,k)=qs_seri(i,k)*corrqql
+        ENDIF
+        IF (ok_bs) THEN
+          qbs_seri(i,k)=qbs_seri(i,k)*corrqql
+        ENDIF
+      ENDDO
+    ENDDO
+    ENDIF
+    !--fin mass fixer
+
     !cc prw  = eau precipitable
     !   prlw = colonne eau liquide 
     !   prlw = colonne eau solide
     !   prbsw = colonne neige soufflee
+    !   water_budget = non-conservation residual from the LMDZ physics
+    !                  (should be equal to machine precision if mass fixer is activated)
     prw(:) = 0.
     prlw(:) = 0.
     prsw(:) = 0.
     prbsw(:) = 0.
+    water_budget(:) = 0.0
     DO k = 1, klev
        prw(:)  = prw(:)  + q_seri(:,k)*zmasse(:,k)
        prlw(:) = prlw(:) + ql_seri(:,k)*zmasse(:,k)
-       prsw(:) = prsw(:) + qs_seri(:,k)*zmasse(:,k)
-       prbsw(:)= prbsw(:) + qbs_seri(:,k)*zmasse(:,k)
+       water_budget(:) = water_budget(:) + (q_seri(:,k)-qx(:,k,ivap)+ql_seri(:,k)-qx(:,k,iliq))*zmasse(:,k)
+       IF (nqo >= 3) THEN
+         prsw(:) = prsw(:) + qs_seri(:,k)*zmasse(:,k)
+         water_budget(:) = water_budget(:) + (qs_seri(:,k)-qx(:,k,isol))*zmasse(:,k)
+       ENDIF
+       IF (nqo >= 4 .AND. ok_bs) THEN
+         prbsw(:)= prbsw(:) + qbs_seri(:,k)*zmasse(:,k)
+         water_budget(:) = water_budget(:) + (qbs_seri(:,k)-qx(:,k,ibs))*zmasse(:,k)
+       ENDIF
     ENDDO
-
-#ifdef ISO
-      DO i = 1, klon
-      do ixt=1,ntraciso
-       xtprw(ixt,i) = 0. 
-       DO k = 1, klev
-        xtprw(ixt,i) = xtprw(ixt,i) + &
-     &           xt_seri(ixt,i,k)*(paprs(i,k)-paprs(i,k+1))/RG
-       ENDDO !DO k = 1, klev
-      enddo !do ixt=1,ntraciso
-      enddo !DO i = 1, klon
-#endif
+    water_budget(:)=water_budget(:)+(rain_fall(:)+snow_fall(:)-evap(:))*pdtphys
+    IF (ok_bs) THEN
+      water_budget(:)=water_budget(:)+bs_fall(:)*pdtphys
+    ENDIF
+    ! Camille Risi mai 2024: pour les isotopes, on attend d'avoir la 4e dimension, ça rendra tout plus facile
+    ! ces variables sont diagnostiques, donc pas indispensables
+
+    !=======================================================================
+    !   SORTIES
+    !=======================================================================
+    !
+    !IM initialisation + calculs divers diag AMIP2
+    !
+    include "calcul_divers.h"
+    !
+    !IM Interpolation sur les niveaux de pression du NMC
+    !   -------------------------------------------------
+    !
+    include "calcul_STDlev.h"
+    !
+    ! slp sea level pressure derived from Arpege-IFS : CALL ctstar + CALL pppmer
+    CALL diag_slp(klon,t_seri,paprs,pplay,pphis,ptstar,pt0,slp)
+    !
     !
     IF (ANY(type_trac == ['inca','inco'])) THEN
@@ -6898 +7206 @@
     !IM global posePB      include "write_bilKP_ave.h"
     !
-
-    !--OB mass fixer 
-    !--profile is corrected to force mass conservation of water
-    IF (mass_fixer) THEN
-    qql2(:)=0.0
-    DO k = 1, klev
-      qql2(:)=qql2(:)+(q_seri(:,k)+ql_seri(:,k)+qs_seri(:,k))*zmasse(:,k)
-    ENDDO
-    
-#ifdef CPP_StratAer
-    IF (ok_qemiss) THEN
-       DO k = 1, klev
-          qql1(:) = qql1(:)+d_q_emiss(:,k)*zmasse(:,k)
-       ENDDO
-    ENDIF
-#endif
-    IF (ok_qch4) THEN
-       DO k = 1, klev
-          qql1(:) = qql1(:)+d_q_ch4_dtime(:,k)*zmasse(:,k)
-       ENDDO
-    ENDIF
-    
-    DO i = 1, klon
-      !--compute ratio of what q+ql should be with conservation to what it is
-      corrqql=(qql1(i)+(evap(i)-rain_fall(i)-snow_fall(i))*pdtphys)/qql2(i)
-      DO k = 1, klev
-        q_seri(i,k) =q_seri(i,k)*corrqql
-        ql_seri(i,k)=ql_seri(i,k)*corrqql
-      ENDDO
-    ENDDO
-#ifdef ISO
-    do ixt=1,ntraciso
-    xtql2(ixt,:)=0.0
-    DO k = 1, klev
-      xtql2(ixt,:)=xtql2(ixt,:)+(xt_seri(ixt,:,k)+xtl_seri(ixt,:,k)+xts_seri(ixt,:,k))*zmasse(:,k)
-    ENDDO
-    DO i = 1, klon
-      !--compute ratio of what q+ql should be with conservation to what it is
-      corrxtql(ixt)=(xtql1(ixt,i)+(xtevap(ixt,i)-xtrain_fall(ixt,i)-xtsnow_fall(ixt,i))*pdtphys)/xtql2(ixt,i)
-      DO k = 1, klev
-        xt_seri(ixt,i,k) =xt_seri(ixt,i,k)*corrxtql(ixt)
-        xtl_seri(ixt,i,k)=xtl_seri(ixt,i,k)*corrxtql(ixt)
-      ENDDO
-    ENDDO   
-    enddo !do ixt=1,ntraciso 
-#endif
-    ENDIF
-    !--fin mass fixer
-
     ! Sauvegarder les valeurs de t et q a la fin de la physique:
     !
@@ -6962 +7221 @@
     xtl_ancien(:,:,:)=xtl_seri(:,:,:)
     xts_ancien(:,:,:)=xts_seri(:,:,:)
+    xtbs_ancien(:,:,:)=xtbs_seri(:,:,:)
 #endif
     CALL water_int(klon,klev,q_ancien,zmasse,prw_ancien)
@@ -7098 +7358 @@
          ok_sync, ptconv, read_climoz, clevSTD,          &
          ptconvth, d_u, d_t, qx, d_qx, zmasse,           &
-         flag_aerosol, flag_aerosol_strat, ok_cdnc,t,u1,v1)
+         flag_aerosol, flag_aerosol_strat, ok_cdnc,t, u1, v1)
 #endif
 
 #ifndef CPP_XIOS
-    CALL write_paramLMDZ_phy(itap,nid_ctesGCM,ok_sync)
-#endif
-
-#endif
-
-! Pour XIOS : On remet des variables a .false. apres un premier appel
-    IF (debut) THEN
-
-      IF (using_xios) THEN
-        swaero_diag=.FALSE.
-        swaerofree_diag=.FALSE.
-        dryaod_diag=.FALSE.
-        ok_4xCO2atm= .FALSE.
-!       write (lunout,*)'ok_4xCO2atm= ',swaero_diag, swaerofree_diag, dryaod_diag, ok_4xCO2atm
-
-        IF (is_master) THEN
-          !--setting up swaero_diag to TRUE in XIOS case 
-          IF (xios_field_is_active("topswad").OR.xios_field_is_active("topswad0").OR. & 
-             xios_field_is_active("solswad").OR.xios_field_is_active("solswad0").OR. & 
-             xios_field_is_active("topswai").OR.xios_field_is_active("solswai").OR.  & 
-               (iflag_rrtm==1.AND.(xios_field_is_active("toplwad").OR.xios_field_is_active("toplwad0").OR. & 
-                                   xios_field_is_active("sollwad").OR.xios_field_is_active("sollwad0"))))  & 
-             !!!--for now these fields are not in the XML files so they are omitted 
-             !!!  xios_field_is_active("toplwai").OR.xios_field_is_active("sollwai") !))) & 
-             swaero_diag=.TRUE. 
-
-          !--setting up swaerofree_diag to TRUE in XIOS case 
-          IF (xios_field_is_active("SWdnSFCcleanclr").OR.xios_field_is_active("SWupSFCcleanclr").OR. &
-             xios_field_is_active("SWupTOAcleanclr").OR.xios_field_is_active("rsucsaf").OR.   &
-             xios_field_is_active("rsdcsaf") .OR. xios_field_is_active("LWdnSFCcleanclr").OR. &
-             xios_field_is_active("LWupTOAcleanclr")) &
-             swaerofree_diag=.TRUE. 
-
-          !--setting up dryaod_diag to TRUE in XIOS case 
-          DO naero = 1, naero_tot-1
-           IF (xios_field_is_active("dryod550_"//name_aero_tau(naero))) dryaod_diag=.TRUE. 
-          ENDDO
-          !
-          !--setting up ok_4xCO2atm to TRUE in XIOS case 
-          IF (xios_field_is_active("rsut4co2").OR.xios_field_is_active("rlut4co2").OR. & 
-             xios_field_is_active("rsutcs4co2").OR.xios_field_is_active("rlutcs4co2").OR. &
-             xios_field_is_active("rsu4co2").OR.xios_field_is_active("rsucs4co2").OR. &
-             xios_field_is_active("rsd4co2").OR.xios_field_is_active("rsdcs4co2").OR. &
-             xios_field_is_active("rlu4co2").OR.xios_field_is_active("rlucs4co2").OR. &
-             xios_field_is_active("rld4co2").OR.xios_field_is_active("rldcs4co2")) &
-             ok_4xCO2atm=.TRUE. 
-        ENDIF
-        !$OMP BARRIER
-        CALL bcast(swaero_diag)
-        CALL bcast(swaerofree_diag)
-        CALL bcast(dryaod_diag)
-        CALL bcast(ok_4xCO2atm)
-!        write (lunout,*)'ok_4xCO2atm= ',swaero_diag, swaerofree_diag, dryaod_diag, ok_4xCO2atm
-      ENDIF !using_xios
-    ENDIF
+      CALL write_paramLMDZ_phy(itap,nid_ctesGCM,ok_sync)
+#endif
+
+#endif
+    ! Petit appelle de sorties pour accompagner le travail sur phyex
+    if ( iflag_physiq == 1 ) then
+        call output_physiqex(debut,jD_eq,pdtphys,presnivs,paprs,u,v,t,qx,cldfra,0.*t,0.*t,0.*t,pbl_tke,theta)
+    endif
 
     !====================================================================
@@ -7200 +7413 @@
     ! Disabling calls to the prt_alerte function
     alert_first_call = .FALSE.
+
     
     IF (lafin) THEN
@@ -7212 +7426 @@
          IF (read_climoz >= 1) THEN
            IF (is_mpi_root) CALL nf95_close(ncid_climoz)
-            DEALLOCATE(press_edg_climoz) ! pointer
-            DEALLOCATE(press_cen_climoz) ! pointer
+            DEALLOCATE(press_edg_climoz)
+            DEALLOCATE(press_cen_climoz)
          ENDIF
        
        ENDIF
+
+       IF (using_xios) THEN
+
+#ifdef INCA
+          IF (type_trac == 'inca') THEN 
+             IF (is_omp_master .AND. grid_type==unstructured) THEN 
+                CALL finalize_inca
+             ENDIF
+          ENDIF
+#endif
+
+          IF (is_omp_master .and. grid_type==unstructured) CALL xios_context_finalize
+       ENDIF
+
+       WRITE(lunout,*) ' physiq fin, nombre de steps ou cvpas = 1 : ', Ncvpaseq1
        
-       IF (using_xios) THEN
-         IF (is_omp_master) CALL xios_context_finalize
-
-#ifdef INCA
-         if (type_trac == 'inca') then 
-            IF (is_omp_master .and. grid_type==unstructured) THEN 
-               CALL finalize_inca
-            ENDIF
-         endif
-#endif
-       ENDIF !using_xios
-       WRITE(lunout,*) ' physiq fin, nombre de steps ou cvpas = 1 : ', Ncvpaseq1
     ENDIF
 

LMDZ6/branches/cirrus/libf/phylmdiso/reevap.F90

@@ -1 @@
-  SUBROUTINE reevap (klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
-   &         d_t_eva,d_q_eva,d_ql_eva,d_qs_eva &
-#ifdef ISO
-             ,xt_seri,xtl_seri,xts_seri,d_xt_eva,d_xtl_eva,d_xts_eva &
-#endif
-   &     )
+  SUBROUTINE reevap (klon,klev,iflag_ice_thermo,t_seri,qx, &
+   &         d_t_eva,d_qx_eva)
 
     ! flag to include modifications to ensure energy conservation (if flag >0)
     USE add_phys_tend_mod, only : fl_cor_ebil 
 #ifdef ISO
-    USE infotrac_phy, ONLY: ntiso   
+    USE infotrac_phy, ONLY: ntiso,nqtot,ivap,iliq,isol,iqWIsoPha
 #ifdef ISOVERIF
     USE isotopes_verif_mod
@@ -23 +19 @@
 
     INTEGER klon,klev,iflag_ice_thermo
-    REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri,q_seri,ql_seri,qs_seri
-    REAL, DIMENSION(klon,klev), INTENT(out) :: d_t_eva,d_q_eva,d_ql_eva,d_qs_eva
+    REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri
+    REAL, DIMENSION(klon,klev,nqtot), INTENT(in) ::     qx
+    REAL, DIMENSION(klon,klev), INTENT(out) :: d_t_eva
+    REAL, DIMENSION(klon,klev,nqtot), INTENT(out) ::    d_qx_eva
 
     REAL za,zb,zdelta,zlvdcp,zlsdcp
-    INTEGER i,k
+    INTEGER i,k,ixt,ivapcur,iliqcur,isolcur    
 
-#ifdef ISO
-    REAL, DIMENSION(ntiso,klon,klev), INTENT(in) :: xt_seri,xtl_seri,xts_seri
-    REAL, DIMENSION(ntiso,klon,klev), INTENT(out) :: d_xt_eva,d_xtl_eva,d_xts_eva
-    integer ixt
-#endif
 
     !--------Stochastic Boundary Layer Triggering: ALE_BL--------
@@ -42 +35 @@
     !IM 100106 BEG : pouvoir sortir les ctes de la physique
     !
+    DO ixt = 1, 1+ntiso
     ! Re-evaporer l'eau liquide nuageuse
     !
+    iliqcur= iqWIsoPha(ixt,iliq)    
+    ivapcur= iqWIsoPha(ixt,ivap)    
+    isolcur= iqWIsoPha(ixt,isol)   
 !print *,'rrevap ; fl_cor_ebil:',fl_cor_ebil,' iflag_ice_thermo:',iflag_ice_thermo,' RVTMP2',RVTMP2
     DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
-       DO i = 1, klon
-        if (fl_cor_ebil .GT. 0) then
-          zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
-          zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
-        else
-          zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
-          !jyg<
-          !  Attention : Arnaud a propose des formules completement differentes
-          !                  A verifier !!!
-          zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
-        end if
-          IF (iflag_ice_thermo .EQ. 0) THEN
-             zlsdcp=zlvdcp
+      DO i = 1, klon
+
+        IF (ixt == 1) THEN ! water
+          IF (fl_cor_ebil > 0) THEN
+            !zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
+            !zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
+            zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*(qx(i,k,ivapcur)+qx(i,k,iliqcur)+qx(i,k,isolcur)))
+            zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*(qx(i,k,ivapcur)+qx(i,k,iliqcur)+qx(i,k,isolcur)))
+          ELSE
+            zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*qx(i,k,ivapcur))
+            !jyg<
+            !  Attention : Arnaud a propose des formules completement differentes
+            !                  A verifier !!!
+            zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*qx(i,k,ivapcur))
+         ENDIF
+          IF (iflag_ice_thermo == 0) THEN
+            zlsdcp=zlvdcp
           ENDIF
           !>jyg
+        ENDIF
+        IF (iflag_ice_thermo == 0) THEN   
+           !pas necessaire a priori
 
-          IF (iflag_ice_thermo.eq.0) THEN   
-             !pas necessaire a priori
+            zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+            zdelta = 0.
+            zb = MAX(0.0,qx(i,k,iliqcur))
+            IF (ixt == 1) THEN
+              za = - MAX(0.0,qx(i,k,iliqcur)) &
+                   * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+              d_t_eva(i,k) = za
+            ENDIF
+            d_qx_eva(i,k,ivapcur)  = zb
+            d_qx_eva(i,k,iliqcur) = -qx(i,k,iliqcur)
+            d_qx_eva(i,k,isolcur) = 0.
 
-             zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
-  zdelta = 0.
-             zb = MAX(0.0,ql_seri(i,k))
-             za = - MAX(0.0,ql_seri(i,k)) &
-                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
-             d_t_eva(i,k) = za
-             d_q_eva(i,k) = zb
-             d_ql_eva(i,k) = -ql_seri(i,k)
-             d_qs_eva(i,k) = 0.
-
-#ifdef ISO
-         do ixt=1,ntiso
-            zb = MAX(0.0,xtl_seri(ixt,i,k))
-            d_xt_eva(ixt,i,k) = zb
-            d_xtl_eva(ixt,i,k) = -xtl_seri(ixt,i,k)
-            d_xts_eva(ixt,i,k) = 0.
-         enddo
-#ifdef ISOVERIF
-      do ixt=1,ntiso
-        call iso_verif_noNaN(xt_seri(ixt,i,k), &
-     &     'reevap 2417: apres evap tot')
-      enddo
-      if (iso_eau.gt.0) then
-              call iso_verif_egalite_choix( &
-     &           xt_seri(iso_eau,i,k),q_seri(i,k), &
-     &          'reevap 1891+, après reevap totale',errmax,errmaxrel)
-              call iso_verif_egalite_choix( &
-     &           xtl_seri(iso_eau,i,k),ql_seri(i,k), &
-     &          'reevap 2209+, après reevap totale',errmax,errmaxrel)
-       endif !if (iso_eau.gt.0) then       
-      if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then  
-            if (q_seri(i,k).gt.ridicule) then  
-               if (iso_verif_o18_aberrant_nostop( &
-     &              xt_seri(iso_HDO,i,k)/q_seri(i,k), &
-     &              xt_seri(iso_O18,i,k)/q_seri(i,k), &
-     &              'reevap 2315: apres reevap totale').eq.1) then
-                  write(*,*) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
-                  write(*,*) 'd_q_eva(i,k)=',d_q_eva(i,k)
-                  write(*,*) 'deltaD(d_q_eva(i,k))=',deltaD(d_xt_eva(iso_HDO,i,k)/d_q_eva(i,k))
-                  write(*,*) 'deltaO18(d_q_eva(i,k))=',deltaO(d_xt_eva(iso_O18,i,k)/d_q_eva(i,k))
-                  stop
-              endif !  if (iso_verif_o18_aberrant_nostop 
-            endif !if (q_seri(i,k).gt.errmax) then   
-        endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then 
-#ifdef ISOTRAC      
-             call iso_verif_traceur(xt_seri(1,i,k), &
-     &           'reevap 2165a')
-             call iso_verif_traceur_pbidouille(xt_seri(1,i,k), &
-     &           'reevap 2165b')
-#endif               
-         
-#endif           
-#endif
-
-          ELSE
-
+        ELSE
+              
              !CR: on r\'e-\'evapore eau liquide et glace
 
@@ -127 +86 @@
              !        za = - MAX(0.0,ql_seri(i,k)) &
              !             * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
-             zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k))
-             za = - MAX(0.0,ql_seri(i,k))*zlvdcp & 
-                  - MAX(0.0,qs_seri(i,k))*zlsdcp
-             d_t_eva(i,k) = za
-             d_q_eva(i,k) = zb
-             d_ql_eva(i,k) = -ql_seri(i,k)
-             d_qs_eva(i,k) = -qs_seri(i,k)
+            IF (ixt == 1) THEN
+              za = - MAX(0.0,qx(i,k,iliqcur))*zlvdcp & 
+                   - MAX(0.0,qx(i,k,iliqcur))*zlsdcp
+              d_t_eva(i,k) = za
+            ENDIF
+            !zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k))
+            !d_q_eva(i,k) = zb
+            !d_ql_eva(i,k) = -ql_seri(i,k)
+            !d_qs_eva(i,k) = -qs_seri(i,k)
 
-#ifdef ISO
-         do ixt=1,ntiso
-            zb = MAX(0.0,xtl_seri(ixt,i,k)+xts_seri(ixt,i,k))
-            d_xt_eva(ixt,i,k) = zb
-            d_xtl_eva(ixt,i,k) = -xtl_seri(ixt,i,k)
-            d_xts_eva(ixt,i,k) = -xts_seri(ixt,i,k)
-         enddo
+            zb = MAX(0.0,qx(i,k,iliqcur)+qx(i,k,isolcur))
+            d_qx_eva(i,k,ivapcur) = zb
+            d_qx_eva(i,k,iliqcur) = -qx(i,k,iliqcur)
+            d_qx_eva(i,k,isolcur) = -qx(i,k,isolcur)
+        ENDIF
 
-#ifdef ISOVERIF
-      do ixt=1,ntiso
-      call iso_verif_noNaN(xt_seri(ixt,i,k), &
-     &     'reevap 2417: apres evap tot')
-      enddo
-      if (iso_eau.gt.0) then
-              call iso_verif_egalite_choix( &
-     &           xt_seri(iso_eau,i,k),q_seri(i,k), &
-     &          'reevap 1891, après réévap totale',errmax,errmaxrel)
-              call iso_verif_egalite_choix( &
-     &           xtl_seri(iso_eau,i,k),ql_seri(i,k), &
-     &          'reevap 2209, après réévap totale',errmax,errmaxrel)
-              call iso_verif_egalite_choix( &
-     &           xts_seri(iso_eau,i,k),qs_seri(i,k), &
-     &          'reevap 2209b, après réévap totale',errmax,errmaxrel)
-       endif !if (iso_eau.gt.0) then
-     
-      if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then  
-            if (q_seri(i,k).gt.ridicule) then  
-               if (iso_verif_o18_aberrant_nostop( &
-     &              xt_seri(iso_HDO,i,k)/q_seri(i,k), &
-     &              xt_seri(iso_O18,i,k)/q_seri(i,k), &
-     &              'reevap 2408: apres reevap totale').eq.1) then
-                  write(*,*) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)                       
-                  stop
-              endif !  if (iso_verif_o18_aberrant_nostop 
-            endif !if (q_seri(i,k).gt.errmax) then   
-        endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then        
-#ifdef ISOTRAC      
-             call iso_verif_traceur(xt_seri(1,i,k), &
-     &           'reevap 2165c')
-             call iso_verif_traceur_pbidouille(xt_seri(1,i,k), &
-     &           'reevap 2165d')
-#endif                  
-#endif                  
-#endif
 
-          ENDIF
+      ENDDO
+    ENDDO
 
-       ENDDO
-    ENDDO
+    ENDDO ! DO ixt = 1, 1+niso*(nzone +1)
 
 RETURN