diff --git a/MAR/code_mar/EUc101001o.e95010 b/MAR/code_mar/EUc101001o.e95010
new file mode 100644
index 0000000000000000000000000000000000000000..902e4e1a55b4a05d81b65663b1acaf8f9322ca29
--- /dev/null
+++ b/MAR/code_mar/EUc101001o.e95010
@@ -0,0 +1,194 @@
+
+---- 1 ---- Initialisation
+
+
+---- 2 ---- Job informations
+
+Begin time : 01/10/2010
+End time : 31/10/2010
+Domain : EUc (/climato_tmp1/tdethinne/MAR/sim/EUc)
+
+Date : Tue 26 Sep 12:07:05 CEST 2023
+Host : srv7
+Work directory: /scratch/tdethinne
+Messages in : /climato_tmp1/tdethinne/MAR/msg
+
+---- 3 ---- Work directory
+
+
+---- 4 ---- input data files
+
+
+ > ECM.2010.10.01-05.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.01-05.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.01-05.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.01-05.EUR.nc.gz
+
+ > ECM.2010.10.06-10.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.06-10.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.06-10.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.06-10.EUR.nc.gz
+
+ > ECM.2010.10.11-15.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.11-15.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.11-15.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.11-15.EUR.nc.gz
+
+ > ECM.2010.10.16-20.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.16-20.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.16-20.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.16-20.EUR.nc.gz
+
+ > ECM.2010.10.21-25.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.21-25.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.21-25.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.21-25.EUR.nc.gz
+
+ > ECM.2010.10.26-31.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.26-31.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.26-31.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.10.26-31.EUR.nc.gz
+
+ > ECM.2010.11.01-05.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.11.01-05.EUR.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.11.01-05.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ECM.2010.11.01-05.EUR.nc.gz
+
+ > ETOPO
+
+smget: /climato_tmp1/fettweis/MAR/in/ETOPO/etopo.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ETOPO/etopo.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ETOPO/etopo.nc.gz
+
+ > ETOPO1
+
+smget: /climato_tmp1/fettweis/MAR/in/ETOPO1/etopo1.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ETOPO1/etopo1.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ETOPO1/etopo1.nc.gz
+
+ > ICEmask
+
+smget: /climato_tmp1/fettweis/MAR/in/ICEmask/ICEmask.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/ICEmask/ICEmask.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/ICEmask/ICEmask.nc.gz
+
+ > FAO
+
+smget: /climato_tmp1/fettweis/MAR/in/FAO/FAO_SOIL.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/FAO_SOIL.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/FAO_SOIL.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/FAO/TEXUNIT.ASC.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/TEXUNIT.ASC.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/TEXUNIT.ASC.gz
+smget: /climato_tmp1/fettweis/MAR/in/FAO/SOILPARAMETER.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/SOILPARAMETER.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/SOILPARAMETER.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/FAO/AFRmax-alb.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/AFRmax-alb.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/FAO/AFRmax-alb.nc.gz
+
+ > SOIL
+
+smget: /climato_tmp1/fettweis/MAR/in/SOIL/GSWP-SOIL.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/SOIL/GSWP-SOIL.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/SOIL/GSWP-SOIL.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/SOIL/HWSDglob.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/SOIL/HWSDglob.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/SOIL/HWSDglob.nc.gz
+
+ > VEGE
+
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/AFRveg_IGBP.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/AFRveg_IGBP.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/AFRveg_IGBP.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/BELveg_IRM.asc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/BELveg_IRM.asc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/BELveg_IRM.asc.gz
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/EURveg_IGBP.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/EURveg_IGBP.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/EURveg_IGBP.nc.gz
+
+ > GlobCover V.2.2 Land Cover
+
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/glcesa3a.nc.gz -> /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/glcesa3a.nc.gz
+uc: /scratch/tdethinne/NST_EUc.10.10.01-31/input/VEGE/glcesa3a.nc.gz
+
+ > MERRA2 LAI/GLF data set
+
+
+---- 5 ---- Stock initialisation
+
+
+---- 6 ---- NESTOR launch
+
+9.65user 2.55system 0:28.39elapsed 42%CPU (0avgtext+0avgdata 895812maxresident)k
+2277128inputs+547832outputs (0major+1004044minor)pagefaults 0swaps
+
+NESTOR run: OK (Tue 26 Sep 12:08:41 CEST 2023)
+
+---- 7 ---- Backup: NESTOR output files
+
+
+> output directory content
+
+total 273876
+-rw------- 1 tdethinne users 1317 Sep 26 12:08 MARdim.inc
+-rw------- 1 tdethinne users 937 Sep 26 12:08 MARdim.inc_old
+-rw------- 1 tdethinne users 1511 Sep 26 12:08 mardim_mod.f90
+-rw------- 1 tdethinne users 2124525 Sep 26 12:08 MARdom.dat
+-rw------- 1 tdethinne users 6163500 Sep 26 12:08 MARdyn.DAT
+-rw------- 1 tdethinne users 32405500 Sep 26 12:08 MARglf.DAT
+-rw------- 1 tdethinne users 181805500 Sep 26 12:08 MARlbc.DAT
+-rw------- 1 tdethinne users 3436 Sep 26 12:08 MAR_LB.inc_old
+-rw------- 1 tdethinne users 5404500 Sep 26 12:08 MARsic.DAT
+-rw------- 1 tdethinne users 1425776 Sep 26 12:08 MARsol.DAT
+-rw------- 1 tdethinne users 136 Sep 26 12:08 MAR_SV.inc
+-rw------- 1 tdethinne users 136 Sep 26 12:08 MAR_SV.inc_nv
+-rw------- 1 tdethinne users 200 Sep 26 12:08 mar_sv_mod.f90
+-rw------- 1 tdethinne users 2462568 Sep 26 12:08 MARsvt.DAT
+-rw------- 1 tdethinne users 2329 Sep 26 12:08 MAR_TV.inc_old
+-rw------- 1 tdethinne users 48604500 Sep 26 12:08 MARubc.DAT
+
+> MAR*.inc* (MARdcl_EUc.2010.10.01.inc)
+
+MARdim.inc
+MARdim.inc_old
+MAR_LB.inc_old
+MAR_SV.inc
+MAR_SV.inc_nv
+MAR_TV.inc_old
+tar: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MAR*.inc* -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARdcl_EUc.2010.10.01.inc.tar
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARdcl_EUc.2010.10.01.inc.tar -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARdcl_EUc.2010.10.01.inc.tar
+
+> MARlbc (MARlbc_EUc.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARlbc_EUc.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARlbc_EUc.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARlbc_EUc.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARlbc_EUc.2010.10.01-31.DAT.gz
+If any trouble here, MARlbc*.DAT is likely to become part of MARini*DAT
+
+> MARglf (MARglf_EUc.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARglf_EUc.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARglf_EUc.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARglf_EUc.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARglf_EUc.2010.10.01-31.DAT.gz
+If any trouble here, MARglf*.DAT is likely to become part of MARini*DAT
+
+> MARsic (MARsic_EUc.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARsic_EUc.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARsic_EUc.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARsic_EUc.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARsic_EUc.2010.10.01-31.DAT.gz
+If any trouble here, MARsic*.DAT is likely to become part of MARini*DAT
+
+> MARubc (MARubc_EUc.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARubc_EUc.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARubc_EUc.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARubc_EUc.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARubc_EUc.2010.10.01-31.DAT.gz
+If any trouble here, MARubc*.DAT is likely to become part of MARini*DAT
+
+> MARdom (MARdom_EUc.2010.10.01.dat)
+
+gzip: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARdom_EUc.2010.10.01.dat -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARdom_EUc.2010.10.01.dat.gz
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARdom_EUc.2010.10.01.dat.gz -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARdom_EUc.2010.10.01.dat.gz
+
+> MARini (MARini_EUc.2010.10.01.DAT)
+
+MARdyn.DAT
+MARsol.DAT
+MARsvt.DAT
+tar: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MAR*.DAT -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARini_EUc.2010.10.01.DAT.tar
+gzip: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARini_EUc.2010.10.01.DAT.tar -> /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARini_EUc.2010.10.01.DAT.tar.gz
+smput: /scratch/tdethinne/NST_EUc.10.10.01-31/output/MARini_EUc.2010.10.01.DAT.tar.gz -> /climato_tmp1/tdethinne/MAR/out/EUc/input/NESTOR/2010/MARini_EUc.2010.10.01.DAT.tar.gz
+
+---- 8 ---- Final job check
+
+EUc101001o job executed successfully on linux
+
+Tue 26 Sep 12:08:54 CEST 2023
+
diff --git a/MAR/code_mar/EUd101001o.e95011 b/MAR/code_mar/EUd101001o.e95011
new file mode 100644
index 0000000000000000000000000000000000000000..c79e9bc667a40c4aa193b705cee924a13e08e687
--- /dev/null
+++ b/MAR/code_mar/EUd101001o.e95011
@@ -0,0 +1,194 @@
+
+---- 1 ---- Initialisation
+
+
+---- 2 ---- Job informations
+
+Begin time : 01/10/2010
+End time : 31/10/2010
+Domain : EUd (/climato_tmp1/tdethinne/MAR/sim/EUd)
+
+Date : Tue 26 Sep 12:07:39 CEST 2023
+Host : srv7
+Work directory: /scratch/tdethinne
+Messages in : /climato_tmp1/tdethinne/MAR/msg
+
+---- 3 ---- Work directory
+
+
+---- 4 ---- input data files
+
+
+ > ECM.2010.10.01-05.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.01-05.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.01-05.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.01-05.EUR.nc.gz
+
+ > ECM.2010.10.06-10.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.06-10.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.06-10.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.06-10.EUR.nc.gz
+
+ > ECM.2010.10.11-15.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.11-15.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.11-15.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.11-15.EUR.nc.gz
+
+ > ECM.2010.10.16-20.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.16-20.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.16-20.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.16-20.EUR.nc.gz
+
+ > ECM.2010.10.21-25.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.21-25.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.21-25.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.21-25.EUR.nc.gz
+
+ > ECM.2010.10.26-31.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.10.26-31.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.26-31.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.10.26-31.EUR.nc.gz
+
+ > ECM.2010.11.01-05.EUR.nc
+
+smget: /MARin3/ERA-5-EUR/2010/ECM.2010.11.01-05.EUR.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.11.01-05.EUR.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ECM.2010.11.01-05.EUR.nc.gz
+
+ > ETOPO
+
+smget: /climato_tmp1/fettweis/MAR/in/ETOPO/etopo.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ETOPO/etopo.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ETOPO/etopo.nc.gz
+
+ > ETOPO1
+
+smget: /climato_tmp1/fettweis/MAR/in/ETOPO1/etopo1.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ETOPO1/etopo1.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ETOPO1/etopo1.nc.gz
+
+ > ICEmask
+
+smget: /climato_tmp1/fettweis/MAR/in/ICEmask/ICEmask.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/ICEmask/ICEmask.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/ICEmask/ICEmask.nc.gz
+
+ > FAO
+
+smget: /climato_tmp1/fettweis/MAR/in/FAO/FAO_SOIL.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/FAO_SOIL.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/FAO_SOIL.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/FAO/TEXUNIT.ASC.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/TEXUNIT.ASC.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/TEXUNIT.ASC.gz
+smget: /climato_tmp1/fettweis/MAR/in/FAO/SOILPARAMETER.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/SOILPARAMETER.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/SOILPARAMETER.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/FAO/AFRmax-alb.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/AFRmax-alb.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/FAO/AFRmax-alb.nc.gz
+
+ > SOIL
+
+smget: /climato_tmp1/fettweis/MAR/in/SOIL/GSWP-SOIL.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/SOIL/GSWP-SOIL.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/SOIL/GSWP-SOIL.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/SOIL/HWSDglob.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/SOIL/HWSDglob.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/SOIL/HWSDglob.nc.gz
+
+ > VEGE
+
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/AFRveg_IGBP.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/AFRveg_IGBP.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/AFRveg_IGBP.nc.gz
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/BELveg_IRM.asc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/BELveg_IRM.asc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/BELveg_IRM.asc.gz
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/EURveg_IGBP.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/EURveg_IGBP.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/EURveg_IGBP.nc.gz
+
+ > GlobCover V.2.2 Land Cover
+
+smget: /climato_tmp1/fettweis/MAR/in/VEGE/glcesa3a.nc.gz -> /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/glcesa3a.nc.gz
+uc: /scratch/tdethinne/NST_EUd.10.10.01-31/input/VEGE/glcesa3a.nc.gz
+
+ > MERRA2 LAI/GLF data set
+
+
+---- 5 ---- Stock initialisation
+
+
+---- 6 ---- NESTOR launch
+
+9.45user 2.11system 0:33.33elapsed 34%CPU (0avgtext+0avgdata 896216maxresident)k
+2281352inputs+547832outputs (10major+428858minor)pagefaults 0swaps
+
+NESTOR run: OK (Tue 26 Sep 12:09:09 CEST 2023)
+
+---- 7 ---- Backup: NESTOR output files
+
+
+> output directory content
+
+total 273876
+-rw------- 1 tdethinne users 1317 Sep 26 12:08 MARdim.inc
+-rw------- 1 tdethinne users 937 Sep 26 12:08 MARdim.inc_old
+-rw------- 1 tdethinne users 1511 Sep 26 12:08 mardim_mod.f90
+-rw------- 1 tdethinne users 2124525 Sep 26 12:08 MARdom.dat
+-rw------- 1 tdethinne users 6163500 Sep 26 12:08 MARdyn.DAT
+-rw------- 1 tdethinne users 32405500 Sep 26 12:09 MARglf.DAT
+-rw------- 1 tdethinne users 181805500 Sep 26 12:09 MARlbc.DAT
+-rw------- 1 tdethinne users 3436 Sep 26 12:08 MAR_LB.inc_old
+-rw------- 1 tdethinne users 5404500 Sep 26 12:09 MARsic.DAT
+-rw------- 1 tdethinne users 1425776 Sep 26 12:08 MARsol.DAT
+-rw------- 1 tdethinne users 136 Sep 26 12:08 MAR_SV.inc
+-rw------- 1 tdethinne users 136 Sep 26 12:08 MAR_SV.inc_nv
+-rw------- 1 tdethinne users 200 Sep 26 12:08 mar_sv_mod.f90
+-rw------- 1 tdethinne users 2462568 Sep 26 12:08 MARsvt.DAT
+-rw------- 1 tdethinne users 2329 Sep 26 12:08 MAR_TV.inc_old
+-rw------- 1 tdethinne users 48604500 Sep 26 12:09 MARubc.DAT
+
+> MAR*.inc* (MARdcl_EUd.2010.10.01.inc)
+
+MARdim.inc
+MARdim.inc_old
+MAR_LB.inc_old
+MAR_SV.inc
+MAR_SV.inc_nv
+MAR_TV.inc_old
+tar: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MAR*.inc* -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARdcl_EUd.2010.10.01.inc.tar
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARdcl_EUd.2010.10.01.inc.tar -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARdcl_EUd.2010.10.01.inc.tar
+
+> MARlbc (MARlbc_EUd.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARlbc_EUd.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARlbc_EUd.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARlbc_EUd.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARlbc_EUd.2010.10.01-31.DAT.gz
+If any trouble here, MARlbc*.DAT is likely to become part of MARini*DAT
+
+> MARglf (MARglf_EUd.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARglf_EUd.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARglf_EUd.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARglf_EUd.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARglf_EUd.2010.10.01-31.DAT.gz
+If any trouble here, MARglf*.DAT is likely to become part of MARini*DAT
+
+> MARsic (MARsic_EUd.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARsic_EUd.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARsic_EUd.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARsic_EUd.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARsic_EUd.2010.10.01-31.DAT.gz
+If any trouble here, MARsic*.DAT is likely to become part of MARini*DAT
+
+> MARubc (MARubc_EUd.2010.10.01-31.DAT)
+
+gzip: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARubc_EUd.2010.10.01-31.DAT -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARubc_EUd.2010.10.01-31.DAT.gz
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARubc_EUd.2010.10.01-31.DAT.gz -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARubc_EUd.2010.10.01-31.DAT.gz
+If any trouble here, MARubc*.DAT is likely to become part of MARini*DAT
+
+> MARdom (MARdom_EUd.2010.10.01.dat)
+
+gzip: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARdom_EUd.2010.10.01.dat -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARdom_EUd.2010.10.01.dat.gz
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARdom_EUd.2010.10.01.dat.gz -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARdom_EUd.2010.10.01.dat.gz
+
+> MARini (MARini_EUd.2010.10.01.DAT)
+
+MARdyn.DAT
+MARsol.DAT
+MARsvt.DAT
+tar: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MAR*.DAT -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARini_EUd.2010.10.01.DAT.tar
+gzip: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARini_EUd.2010.10.01.DAT.tar -> /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARini_EUd.2010.10.01.DAT.tar.gz
+smput: /scratch/tdethinne/NST_EUd.10.10.01-31/output/MARini_EUd.2010.10.01.DAT.tar.gz -> /climato_tmp1/tdethinne/MAR/out/EUd/input/NESTOR/2010/MARini_EUd.2010.10.01.DAT.tar.gz
+
+---- 8 ---- Final job check
+
+EUd101001o job executed successfully on linux
+
+Tue 26 Sep 12:09:26 CEST 2023
+
diff --git a/MAR/code_mar/MAR_pp.def b/MAR/code_mar/MAR_pp.def
new file mode 100644
index 0000000000000000000000000000000000000000..8302f108e0236cab08f760f4837cb0ab30a8a493
--- /dev/null
+++ b/MAR/code_mar/MAR_pp.def
@@ -0,0 +1,9 @@
+#define SB .true. /* Surface Boundary: modified externally (from Campain Data) */
+#define KC .true. /* TURBULENCE: T.K.E.(mz1):= T.K.E.(mz) */
+#define TZ .true. /* Z0 (Momentum) (typical value in polar models) */
+#define II .true. /* Search new Ice/Snow Interface */
+#define XF .true. /* For Xavier Fettweis */
+#define AC .true. /* For Cecile Agosta */
+#define up .true. /* For having more precip along the margin */
+#define SU .true. /* Slush Switch */
+#define GP .true. /* Soil /Vegetation Model: LAI, GLF Variations NOT prescrib. */
\ No newline at end of file
diff --git a/MAR/code_mar/advbot_4.f90 b/MAR/code_mar/advbot_4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1e64d1e689d164ad4b805b8f36e4adc0e0fae4aa
--- /dev/null
+++ b/MAR/code_mar/advbot_4.f90
@@ -0,0 +1,167 @@
+#include "MAR_pp.def"
+subroutine ADVbot_4(flu, vec, aa0, aa1, aa2, aa3, aa4, &
+ cnp, cnm, sip, sim, sid, mmm, logpos)
+ ! +
+ ! +------------------------------------------------------------------------+
+ ! | MAR ADVECTION 16-12-2000 MAR |
+ ! | subroutine ADVbot_4 includes the Advection Contribution |
+ ! | for positive definite scalar Variables |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: vec : variable to advect |
+ ! | ^^^^^ aa0,aa1,aa2,aa3,aa4: Work Area |
+ ! | cnp : Courant Number (x+ Cell) |
+ ! | cnm : Courant Number (x- Cell) |
+ ! | sip,sim,sid : Work Area |
+ ! | mmm : Dimension of the Variables |
+ ! | logpos : Positive definite Constraint Switch |
+ ! | |
+ ! | OUTPUT: flu : advection fluxes at each cell boundaries |
+ ! | ^^^^^^ |
+ ! | |
+ ! | METHOD : The Flux Form of the Equation is solved: |
+ ! | ^^^^^^^^ d(Qp*)/dt + d(uQp*)/dx + d(vQp*)/dy + d(sQp*)/ds = 0 |
+ ! | The scheme is that of Bott (1989) MWR, 117, 1007-1009 |
+ ! | and Bott (1989) MWR, 117, 2635 (Table 1) |
+ ! | |
+ ! | # OPTIONS: STANDARD: Bott Scheme, order 0 (zero) |
+ ! | # ^^^^^^^^ #B+ #B2 Bott Scheme, order 2 |
+ ! | # #B+ #B4 Bott Scheme, order 4 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marphy
+ ! +
+ implicit none
+ ! +
+ integer mmm, logpos
+ ! +
+ real flu(0:mmm)
+ real vec(0:mmm)
+ real aa0(0:mmm)
+ real aa1(0:mmm)
+ real aa2(0:mmm)
+ real aa3(0:mmm)
+ real aa4(0:mmm)
+ real cnp(0:mmm)
+ real cnm(0:mmm)
+ real sip(0:mmm)
+ real sim(0:mmm)
+ real sid(0:mmm)
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer i, im1, ip1, im2, ip2
+ real epsadv, propo1, propo2, propo3, propo4, propo5
+ real prone1, prone2, prone3, prone4, prone5
+ ! +
+ ! +
+ ! +--DATA
+ ! + ====
+ ! +
+ data epsadv/1.e-6/
+ ! +
+ do i = 0, mmm
+ im1 = max(i - 1, 0)
+ ip1 = min(i + 1, mmm)
+ im2 = max(i - 2, 0)
+ ip2 = min(i + 2, mmm)
+ ! +
+ ! +
+ ! +--Approximation of vec
+ ! + --------------------
+ ! +
+ ! +--Polynomial Fitting, as in Bott (1989) MWR, 117, 2635 (Table 1)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ aa0(i) = vec(i)
+#if(B2)
+ ! aa0, aa1, aa2 : Lagrange Polynomial Coefficients
+ ! (see Bott 1989 MWR Table 1 p.2635)
+ aa0(i) = (aa0(i) - vec(ip1) - vec(im1)) / 24.0
+ aa1(i) = 0.50 * (vec(ip1) - vec(im1))
+ aa2(i) = 0.50 * (vec(ip1) + vec(im1)) - vec(i)
+#endif
+ ! +
+ aa0(i) = (9.0 * vec(ip2) - 116.0 * vec(ip1) + 2134.0 * vec(i) &
+ - 116.0 * vec(im1) + 9.0 * vec(im2)) / 1920.0
+ aa1(i) = (-5.0 * vec(ip2) + 34.0 * vec(ip1) &
+ - 34.0 * vec(im1) + 5.0 * vec(im2)) / 48.0
+ aa2(i) = (-3.0 * vec(ip2) + 36.0 * vec(ip1) - 66.0 * vec(i) &
+ + 36.0 * vec(im1) - 3.0 * vec(im2)) / 48.0
+ aa3(i) = (vec(ip2) - 2.0 * vec(ip1) &
+ + 2.0 * vec(im1) - vec(im2)) / 12.0
+ aa4(i) = (vec(ip2) - 4.0 * vec(ip1) + 6.0 * vec(i) &
+ - 4.0 * vec(im1) + vec(im2)) / 24.0
+ enddo
+ ! +
+ ! +--Integral (7), Bott 1989 MWR 117 p. 1007
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = 0, mmm
+ propo1 = 1.0 - 2.0 * cnp(i)
+ propo2 = propo1 * propo1
+ propo3 = propo2 * propo1
+ propo4 = propo3 * propo1
+ propo5 = propo4 * propo1
+ sip(i) = aa0(i) * cnp(i) &
+ + (aa1(i) / 8.0) * (1.0 - propo2) &
+ + (aa2(i) / 24.0) * (1.0 - propo3) &
+ + (aa3(i) / 64.0) * (1.0 - propo4) &
+ + (aa4(i) / 160.0) * (1.0 - propo5)
+ enddo
+ ! +
+ ! +--Integral (8), Bott 1989 MWR 117 p. 1008
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = 0, mmm
+ ip1 = min(i + 1, mmm)
+ prone1 = 1.00 - 2.0 * cnm(i)
+ prone2 = prone1 * prone1
+ prone3 = prone2 * prone1
+ prone4 = prone3 * prone1
+ prone5 = prone4 * prone1
+ sim(i) = aa0(ip1) * cnm(i) &
+ - (aa1(ip1) / 8.0) * (1.0 - prone2) &
+ + (aa2(ip1) / 24.0) * (1.0 - prone3) &
+ - (aa3(ip1) / 64.0) * (1.0 - prone4) &
+ + (aa4(ip1) / 160.0) * (1.0 - prone5)
+ enddo
+ ! +
+ ! +
+ ! +--Positive Definite Constraint, Bott 1989, MWR 117 (14) p.1008
+ ! + ------------------------------------------------------------
+ ! +
+ if(logpos == 1) then
+ ! +
+ ! +--Positive Definite Constraint is applied
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = 0, mmm
+ sip(i) = max(sip(i), zero)
+ sim(i) = max(sim(i), zero)
+ sid(i) = aa0(i) + aa2(i) / 12.0 &
+ + aa4(i) / 80.0
+ enddo
+ ! +
+ do i = 0, mmm
+ im1 = max(i - 1, 0)
+ sid(i) = max(sid(i), sip(i) + sim(im1) + epsadv)
+ enddo
+ ! +
+ do i = 0, mmm
+ ip1 = min(i + 1, mmm)
+ flu(i) = sip(i) * vec(i) / sid(i) - sim(i) * vec(ip1) / sid(ip1)
+ enddo
+ ! +
+ else
+ ! +
+ ! +--Positive Definite Constraint is not applied
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = 0, mmm
+ flu(i) = sip(i) - sim(i)
+ enddo
+ ! +
+ endif
+ ! +
+ return
+endsubroutine ADVbot_4
diff --git a/MAR/code_mar/aftp11677 b/MAR/code_mar/aftp11677
new file mode 100644
index 0000000000000000000000000000000000000000..624f2c25cd4d25748c8ea0feffb492696acbd9eb
--- /dev/null
+++ b/MAR/code_mar/aftp11677
@@ -0,0 +1,72 @@
+ECM.2010.01.01-05.EUR.nc.gz
+ECM.2010.01.06-10.EUR.nc.gz
+ECM.2010.01.11-15.EUR.nc.gz
+ECM.2010.01.16-20.EUR.nc.gz
+ECM.2010.01.21-25.EUR.nc.gz
+ECM.2010.01.26-31.EUR.nc.gz
+ECM.2010.02.01-05.EUR.nc.gz
+ECM.2010.02.06-10.EUR.nc.gz
+ECM.2010.02.11-15.EUR.nc.gz
+ECM.2010.02.16-20.EUR.nc.gz
+ECM.2010.02.21-25.EUR.nc.gz
+ECM.2010.02.26-28.EUR.nc.gz
+ECM.2010.03.01-05.EUR.nc.gz
+ECM.2010.03.06-10.EUR.nc.gz
+ECM.2010.03.11-15.EUR.nc.gz
+ECM.2010.03.16-20.EUR.nc.gz
+ECM.2010.03.21-25.EUR.nc.gz
+ECM.2010.03.26-31.EUR.nc.gz
+ECM.2010.04.01-05.EUR.nc.gz
+ECM.2010.04.06-10.EUR.nc.gz
+ECM.2010.04.11-15.EUR.nc.gz
+ECM.2010.04.16-20.EUR.nc.gz
+ECM.2010.04.21-25.EUR.nc.gz
+ECM.2010.04.26-30.EUR.nc.gz
+ECM.2010.05.01-05.EUR.nc.gz
+ECM.2010.05.06-10.EUR.nc.gz
+ECM.2010.05.11-15.EUR.nc.gz
+ECM.2010.05.16-20.EUR.nc.gz
+ECM.2010.05.21-25.EUR.nc.gz
+ECM.2010.05.26-31.EUR.nc.gz
+ECM.2010.06.01-05.EUR.nc.gz
+ECM.2010.06.06-10.EUR.nc.gz
+ECM.2010.06.11-15.EUR.nc.gz
+ECM.2010.06.16-20.EUR.nc.gz
+ECM.2010.06.21-25.EUR.nc.gz
+ECM.2010.06.26-30.EUR.nc.gz
+ECM.2010.07.01-05.EUR.nc.gz
+ECM.2010.07.06-10.EUR.nc.gz
+ECM.2010.07.11-15.EUR.nc.gz
+ECM.2010.07.16-20.EUR.nc.gz
+ECM.2010.07.21-25.EUR.nc.gz
+ECM.2010.07.26-31.EUR.nc.gz
+ECM.2010.08.01-05.EUR.nc.gz
+ECM.2010.08.06-10.EUR.nc.gz
+ECM.2010.08.11-15.EUR.nc.gz
+ECM.2010.08.16-20.EUR.nc.gz
+ECM.2010.08.21-25.EUR.nc.gz
+ECM.2010.08.26-31.EUR.nc.gz
+ECM.2010.09.01-05.EUR.nc.gz
+ECM.2010.09.06-10.EUR.nc.gz
+ECM.2010.09.11-15.EUR.nc.gz
+ECM.2010.09.16-20.EUR.nc.gz
+ECM.2010.09.21-25.EUR.nc.gz
+ECM.2010.09.26-30.EUR.nc.gz
+ECM.2010.10.01-05.EUR.nc.gz
+ECM.2010.10.06-10.EUR.nc.gz
+ECM.2010.10.11-15.EUR.nc.gz
+ECM.2010.10.16-20.EUR.nc.gz
+ECM.2010.10.21-25.EUR.nc.gz
+ECM.2010.10.26-31.EUR.nc.gz
+ECM.2010.11.01-05.EUR.nc.gz
+ECM.2010.11.06-10.EUR.nc.gz
+ECM.2010.11.11-15.EUR.nc.gz
+ECM.2010.11.16-20.EUR.nc.gz
+ECM.2010.11.21-25.EUR.nc.gz
+ECM.2010.11.26-30.EUR.nc.gz
+ECM.2010.12.01-05.EUR.nc.gz
+ECM.2010.12.06-10.EUR.nc.gz
+ECM.2010.12.11-15.EUR.nc.gz
+ECM.2010.12.16-20.EUR.nc.gz
+ECM.2010.12.21-25.EUR.nc.gz
+ECM.2010.12.26-31.EUR.nc.gz
diff --git a/MAR/code_mar/cva_filtering.f90 b/MAR/code_mar/cva_filtering.f90
new file mode 100644
index 0000000000000000000000000000000000000000..578494de828cc38452a1b56921ec9a4ffaa1148a
--- /dev/null
+++ b/MAR/code_mar/cva_filtering.f90
@@ -0,0 +1,63 @@
+subroutine cva_filtering(wrk1, level1)
+
+ ! +------------------------------------------------------------------------+
+ ! | MAR CONVECTION 11-01-2016 MAR |
+ ! | |
+ ! | subroutine CVA_filtering |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+
+ implicit none
+
+ ! weight : weight for the central pixel
+ real, parameter :: weight = 8
+
+ integer i, j, k, m
+ integer l, kk, level1, level2
+ real wrk1(mx, my, mz), uu, vv
+ real wrk2(mx, my), wrk3(mx, my), w
+
+ level2 = min(max(1, level1), mz)
+
+!$OMP PARALLEL DO private(i,j,k,kk,l,w,uu,vv,wrk3,wrk2)
+ do kk = 1, level2
+ do j = 6, my - 5
+ do i = 6, mx - 5
+
+ wrk3(i, j) = 0
+ wrk2(i, j) = 0
+
+ do k = -1, 1
+ do l = -1, 1
+ w = 1
+ if(l == 0) w = 2
+ if(k == 0) w = 2
+ if(l == 0 .and. k == 0) w = weight
+
+ if(i + k > mx - 5 .or. i + k < 6) w = 0
+ if(j + l > my - 5 .or. j + l < 6) w = 0
+
+ wrk3(i, j) = wrk3(i, j) + w
+ wrk2(i, j) = wrk2(i, j) + wrk1(i + k, j + l, kk) * w
+ enddo
+ enddo
+
+ wrk2(i, j) = wrk2(i, j) / wrk3(i, j)
+ enddo
+ enddo
+
+ do j = 6, my - 5
+ do i = 6, mx - 5
+ wrk1(i, j, kk) = wrk2(i, j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+endsubroutine cva_filtering
diff --git a/MAR/code_mar/cvagen_mnh.f90 b/MAR/code_mar/cvagen_mnh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..77913dfcde4a8616c4ceb108c741ac7c0d482233
--- /dev/null
+++ b/MAR/code_mar/cvagen_mnh.f90
@@ -0,0 +1,819 @@
+#include "MAR_pp.def"
+subroutine CVAgen_MNH
+ ! +------------------------------------------------------------------------+
+ ! | MAR CONVECTION Mon 25-01-2021 MAR |
+ ! | subroutine CVAgen links MAR to a CONVECTIVE ADJUSMENT procedure |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ itexpe : Experiment Iteration Counter |
+ ! | itConv : Adjustment Calls Counter |
+ ! | dt_loc2 : Mass Flux Scheme: Time Step |
+ ! | |
+ ! | dx : grid spacing (m) |
+ ! | dy : grid spacing (m) |
+ ! | tairDY(mx,my,mz) : air temperature (K) |
+ ! | qiHY(mx,my,mz) : air cloud crystals conc. (kg/kg) |
+ ! | qsHY(mx,my,mz) : air snow flakes conc. (kg/kg) |
+ ! | qwHY(mx,my,mz) : air cloud droplets conc. (kg/kg) |
+ ! | qrHY(mx,my,mz) : air rain drops conc. (kg/kg) |
+ ! | |
+ ! | INPUT / OUTPUT: dx : grid spacing (m) |
+ ! | ^^^^^^^^^^^^^^^ dy : grid spacing (m) |
+ ! | pktaDY(mx,my,mz) : air temperature (K) |
+ ! | qvDY(mx,my,mz) : air specific humidity (kg/kg) |
+ ! | rainHY(mx,my) : rain Precipitation (m) |
+ ! | rainCA(mx,my) : rain Precipitation (m) |
+ ! | |
+ ! | REFER. : 1) MesoNH CONVECTIVE ADJUSMENT Routine |
+ ! | ^^^^^^^^ 2) cfr. head of subroutine CONVECTION |
+ ! | |
+ ! | # OPTIONS: #pb Limited Scalar Operations ==> NO vectorization |
+ ! | # ^^^^^^^^ #EW Energy and Water ?Conservation |
+ ! | # #AN Anabatic Wind Parameterization |
+ ! | # #GU Gust Front Parameterization |
+ ! | # #gu Gust Front Parameterization (NO vectorization) |
+ ! | # #GW Gust Front Parameterization (OUTPUT) |
+ ! | |
+ ! | MODIF. HGall?e: 18-11-2004: Adaptation to CVAmnh.f90.laurent |
+ ! | ^^^^^^ (Argument kensbl of CONVECTION removed) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_te
+ use mar_hy
+ use mar_ca
+ use mar_pb
+ use mar_sl
+ use mar_ra
+ use marmagic
+#if(EW)
+ use mar_ew
+#endif
+
+ implicit none
+#if(AN)
+ real rANA, hANA(mx, my)
+ common / CVAgen_MNH_ANA / rANA, hANA
+#endif
+#if(GW)
+ integer i_Gmax, k_Gmax, i_Gmin, k_Gmin
+ real waGmax, TaGmin
+#endif
+#if(GU)
+ real waGust(mx, my, mzz)
+ real TaGust(mx, my, mz), dtxLoc
+ common / CVAgen_MNHgust / TaGust, dtxLoc
+#endif
+
+ logical Odeep, Oshal
+ common / CVAgen_MNH_lt / Odeep, Oshal
+ real pdtCVx, pdtCV, PTdcv, PTscv
+ integer nntCV0, jjtCV0, iitCV0
+ common / CVAgen_MNH_rt / pdtCVx, pdtCV, PTdcv, PTscv
+ common / CVAgen_MNH_nt / nntCV0, jjtCV0, iitCV0
+
+ integer KLON_0, KLEV_0
+ parameter(KLON_0=KLON, KLEV_0=KLEV)
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ character * 3 vectcv
+ integer klcvOK, dt_loc2
+ integer iklon, klc
+
+ logical Odeep0, Oshal0, Orset0, Odown0, OsetA0, OCvTC0
+ integer kidia0, kfdia0, kbdia0, ktdia0, kIce_0, kensbl
+
+ real pdtCV0, PTdcv0, PTscv0
+ real Pdxdy0(KLON)
+ real P_pa_0(KLON, KLEV)
+ real P_za_0(KLON, KLEV)
+ real P_Ta_0(KLON, KLEV)
+ real P_Qa_0(KLON, KLEV)
+ real P_Qw_0(KLON, KLEV)
+ real P_Qi_0(KLON, KLEV)
+ real P_Ua_0(KLON, KLEV)
+ real P_Va_0(KLON, KLEV)
+ real P_Wa_0(KLON, KLEV)
+ real P_TKE(KLON, KLEV)
+ real ratio_rfsf, ratio_temp, ratio_prec
+
+ integer locCVA
+ real OK_CVA, MAX_TT(mx, my), min_TT_off
+ real wrk1(mx, my, mz), wrk1_mx
+#if(AN)
+ real bANA, zANA, wANA(mx, my, mz), zlev
+ real dANA, vANA, xANA
+#endif
+
+#if(EW)
+ ! +--Diagnostic Variables
+ ! + --------------------
+ integer irmx, jrmx, iter_0
+ real rr_max, temp_r, energ0, water0, waterb
+#endif
+
+ ! +--Mass Flux convective Scheme: Set Up DATA
+ ! + ========================================
+
+ data kidia0/1/
+ ! +... kidia0 : value of the first point in x
+
+ data kbdia0/1/
+ ! +... kbdia0 : vertical computations: lowest level
+
+ data ktdia0/1/
+ ! +... ktdia0 : vertical computations: over KLEV + 1 - ktdia0 levels
+
+ data pdtCV0/600./
+ !XF
+ ! +... pdtCV0 : time interval between 2 CALLs of deep convection
+
+ data Odeep0/.true./
+ ! +... Odeep0 : Deep Convection Switch
+
+ data Oshal0/.true./
+ ! +... Oshal0 : Shallow Convection Switch
+
+ data Orset0/.true./
+ ! +... Orset0 : refresh or not all tendencies at every call
+
+ data Odown0/.true./
+ ! +... Odown0 : take or not convective downdrafts into account
+
+ data kIce_0/1/
+ ! +... kIce_0 : flag for ice ( 1 = yes,
+ ! + 0 = no ice )
+ data OsetA0/.true./
+ ! +... OsetA0 : logical to set convective adjustment time by user
+
+ data PTdcv0/1200./
+ ! +... PTdcv0 : user defined deep adjustment time
+
+ data PTscv0/1200./
+ ! +... PTscv0 : user defined shallow adjustment time
+
+ data kensbl/3/
+ ! +... kensbl : value for a "climate" run
+
+ data OCvTC0/.false./
+ ! +... OCvTC0 : flag to compute convective transport
+ ! + for chemical tracer
+
+ ! XF
+ data min_TT_off/270.15/
+ ! + min_TT_off : temperature min for switching on the convect. adjust.
+
+#if(AN)
+ ! +--Anabatic Breeze Parameterization
+ ! + --------------------------------
+ ! xANA : Characteristic Mountain Width Scale
+ data xANA/10.0e+3/
+ ! vANA : Characteristic Mountain Breeze Wind Scale
+ data vANA/4.0e+0/
+#endif
+
+ ! +--SET UP CONVECTION SWITCHES
+ ! + ==========================
+
+ do i = 1, mx; do j = 1, my
+ if(adj_CA(i, j) == 0 .or. itexpe == 0) then
+ drr_CA(i, j) = 0.
+ dss_CA(i, j) = 0.
+ do k = 1, mz
+ dpktCA(i, j, k) = 0.
+ dqv_CA(i, j, k) = 0.
+ dqw_CA(i, j, k) = 0.
+ dqi_CA(i, j, k) = 0.
+ enddo
+ endif
+ enddo;
+ enddo
+
+ if(iterun == 0) then
+ !XF
+ if(MFLX_d) then
+ Odeep = MFLX_d
+ else
+ Odeep = Odeep0
+ write(6, *) 'Deep Convection Switch set to ', Odeep
+ endif
+ if(MFLX_s) then
+ Oshal = MFLX_s
+ else
+ Oshal = Oshal0
+ write(6, *) 'Shallow Convection Switch set to ', Oshal
+ endif
+
+ if(tMFLXd > 0.) then
+ pdtCVx = tMFLXd
+ else
+ !XF
+ pdtCVx = max(600., min(pdtCV0, 4.*dt))
+#if(AC)
+ pdtCVx = 1800.
+#endif
+#if(GL)
+ pdtCVx = 1200.
+#endif
+ write(6, *) 'Interv. Convection call set to ', pdtCVx
+ endif
+
+ if(aMFLXd > 0.) then
+ PTdcv = aMFLXd
+ else
+ ! OsetA0 must be .true.
+ PTdcv = max(600., min(PTdcv0, 4.*dt))
+#if(GL)
+ PTdcv = 1200.
+#endif
+#if(AC)
+ PTdcv = 1800.
+#endif
+ write(6, *) 'Deep Convection Time Scale set to ', PTdcv
+ endif
+ if(aMFLXs > 0.) then
+ PTscv = aMFLXs
+ else
+ ! OsetA0 must be .true.
+ PTscv = max(600., min(PTscv0, 4.*dt))
+#if(GL)
+ ! PTscv = 2 * PTdcv
+ PTscv = 1200
+#endif
+#if(AC)
+ PTscv = 1800.
+#endif
+ write(6, *) 'Shallow Convection Time Scale set to ', PTscv
+ endif
+
+ endif
+
+ ! +--Set UP Anabatic Breeze Parameterization
+ ! + =======================================
+
+ if(itexpe == 0) then
+#if(GU)
+ open(unit=70, status='new', file='W_GUST.out')
+ rewind 70
+ dtxLoc = dt_loc2 / dx
+#endif
+#if(AN)
+ ! rANA : Subgrid Mountain Breeze: Horizontal Divergence
+ ! + (Factor 2 included for 2 horizontal Directions)
+ rANA = 2.0d+0 * vANA / xANA
+ do j = 1, my
+ do i = 1, mx
+ dANA = sh(i, j) &
+ - 0.25 * (sh(im1(i), j) + sh(ip1(i), j) &
+ + sh(i, jm1(j)) + sh(i, jp1(j)))
+ ! hANA: D("Subgrid Mountain" Height - "Resolved Mountain" Height)
+ hANA(i, j) = abs(dANA) * max(zero, dx / xANA - unun)
+ hANA(i, j) = sh(i, j) * 2.0d+0
+ enddo
+ enddo
+#endif
+#if(GU)
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ TaGust(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+#endif
+
+ ! +--Set UP Verification
+ ! + ===================
+
+ klcvOK = mx2 * my2
+ klcvOK = 1
+ if(klon /= klcvOK) then
+ if(klon > 1) then
+ vectcv = 'NON'
+ else
+ vectcv = ' '
+ endif
+ write(6, 6000) klon, klcvOK, vectcv
+6000 format(/, '++++++++ klon (mardim_mod.f90) =', i6, ' .NE.', i6, ' ++++++++++++++', &
+ /, '++++++++ NOT adapted to a ', a3, ' vectorized code ++++++++++++++', &
+ /, '++++++++ BAD SET UP of #pb or klon parameter ++++++++++++++', &
+ /, ' ==> !?%@&* Emergency EXIT in CVAgen_MNH')
+ stop
+ endif
+
+#if(EW)
+ ! +--Mass Flux convective Scheme: Set Up Energy/Water Verification
+ ! + =============================================================
+ energ0 = 0.0
+ water0 = 0.0
+ iter_0 = 0
+ write(6, 600)
+600 format(/, ' CVAgen_MNH: Energy/Water Verification Set UP')
+#endif
+ endif
+
+ ! +--Mass Flux Scheme: Set Up Time Stepping
+ ! + ======================================
+
+ dt_loc2 = dt ! cvagen_mnh is called every time step
+
+ if(iterun == 0) then
+
+ adj_CA = -1
+
+ pdtCV = pdtCVx
+#if(xx)
+ pdtCV = min(dt_loc2, pdtCVx)
+#endif
+ if(pdtCV < dt_loc2) then
+ pdtCV = dt_loc2
+ jjtCV0 = 1
+ else
+ jjtCV0 = pdtCV / dt_loc2
+ ! +... jjtCV0 : Number of Diffusion Steps for 1 Convective Step
+
+ pdtCV = dt_loc2 * jjtCV0
+ ! +... pdtCV : Calibrated Convection Time Step
+
+ endif
+ iitCV0 = 0
+ endif
+
+ ! +--Update Convective Mass Flux
+ ! + ===========================
+
+ if(mod(iitCV0, jjtCV0) == 0) then
+
+#if(AN)
+ ! +--Contribution from Subgrid Mountain Breeze
+ ! + -----------------------------------------
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ zlev = gplvDY(i, j, k) * grvinv
+ bANA = min(zlev, zi__TE(i, j))
+ zANA = hANA(i, j) + 2.0 * bANA
+ if(zlev <= zANA .and. &
+ TairSL(i, j) > tairDY(i, j, mz)) then
+ ! Half Integrated Horizontal Divergence
+ wANA(i, j, k) = rANA * 0.5 * bANA
+ else
+ wANA(i, j, k) = 0.0
+ endif
+ enddo
+ enddo
+ enddo
+#endif
+
+#if(GW)
+ ! +--Contribution from the Cold Air Pool
+ ! + -----------------------------------
+ waGmax = 0.
+ TaGmin = 0.
+#endif
+#if(GU)
+ do k = mz, 2, -1
+ do j = jp11, my1
+ do i = ip11, mx1
+ waGust(i, j, k) = ((4.0 * TaGust(i, j, k) &
+ - TaGust(ip1(i), j, k) - TaGust(i, jp1(j), k) &
+ - TaGust(im1(i), j, k) - TaGust(i, jm1(j), k)) &
+ * (0.50e6 / dx) &
+ * (gpmiDY(i, j, k) - gpmiDY(i, j, k + 1)) &
+ + waGust(i, j, k + 1) * gplvDY(i, j, k + 1)) &
+ / gplvDY(i, j, k) &
+ * max(zero, sign(unun, zi__TE(i, j) &
+ - gplvDY(i, j, k) * grvinv))
+ waGust(i, j, k) = max(zero, waGust(i, j, k))
+#endif
+#if(GW)
+ if(TaGmin < TaGust(i, j, k)) then
+ TaGmin = TaGust(i, j, k)
+ i_Gmin = i
+ k_Gmin = k
+ endif
+ if(waGmax < waGust(i, j, k)) then
+ waGmax = waGust(i, j, k)
+ i_Gmax = i
+ k_Gmax = k
+ endif
+#endif
+#if(GU)
+ enddo
+ enddo
+ enddo
+#endif
+#if(GW)
+ i_Gmax = max(2, i_Gmax)
+ i_Gmax = min(mx1, i_Gmax)
+ k_Gmax = max(1, k_Gmax)
+ k_Gmax = min(mz, k_Gmax)
+ write(70, 700) itexpe, &
+ i_Gmax, k_Gmax,(waGust(i, 1, k_Gmax), i=i_Gmax - 1, i_Gmax + 1), &
+ i_Gmin, k_Gmin,(TaGust(i, 1, k_Gmax), i=i_Gmax - 1, i_Gmax + 1), &
+ grvinv * gplvDY(i_Gmax, 1, k_Gmax), zi__TE(i_Gmax, 1)
+700 format(2i6, i4, 3f9.3, i6, i4, 3f9.3, 2f12.0)
+#endif
+
+ ! +--Mass Flux convective Scheme: Set Up Vertical Profiles
+ ! + -----------------------------------------------------
+
+ kfdia0 = klon
+ ! +... kfdia0 : value of the last point in x
+
+ iklon = 0
+
+ !XF
+ max_TT = -273.15
+
+ !$OMP PARALLEL do &
+ !$OMP firstprivate(i,k,klc,iklon,OK_CVA, &
+ !$OMP kidia0, kfdia0, kbdia0, ktdia0, &
+ !$OMP pdtCV , Odeep , Oshal , Orset0, Odown0, kIce_0, &
+ !$OMP OsetA0, PTdcv , PTscv , &
+ !$OMP kensbl,ratio_rfsf ,ratio_temp,ratio_prec, &
+ !$OMP P_pa_0, P_za_0, Pdxdy0, &
+ !$OMP P_Ta_0, P_Qa_0, P_Qw_0, P_Qi_0, P_Ua_0, P_Va_0, P_Wa_0, &
+ !$OMP Kstep1, PdTa_1, PdQa_1, PdQw_1, PdQi_1, &
+ !$OMP Pdrr_1, Pdss_1, &
+ !$OMP PuMF_1, PdMF_1, Pfrr_1, Pfss_1, Pcape1, K_CbT1, K_CbB1, &
+ !$OMP OCvTC0, P_CH_0, PdCH_1,P_TKE) &
+ !$OMP schedule(dynamic)
+
+ do j = 6, my - 5
+ do i = 6, mx - 5
+
+ iklon = 1 + iklon
+ iklon = 1
+
+ Pdxdy0(iklon) = dx3(i, j) * dy3(i, j)
+ ! +... Pdxdy0 : grid area [m2]
+
+ do klc = 1, klev
+ k = mzz - klc
+ P_pa_0(iklon, klc) = (pstDY(i, j) * sigma(k) + ptopDY) * 1.e3
+ ! +... P_pa_0 : pressure in layer [Pa]
+
+ P_za_0(iklon, klc) = gplvDY(i, j, k) * grvinv
+ ! +... P_za_0 : height of model layer [m]
+
+ P_Ta_0(iklon, klc) = tairDY(i, j, k)
+ ! +... P_Ta_0 : grid scale T at time t [K]
+
+ !XF
+ max_TT(i, j) = max(max_TT(i, j), tairDY(i, j, k))
+ !XF! P_Qa_0 : grid scale water vapor at time t [kg/kg]
+ P_Qa_0(iklon, klc) = qvDY(i, j, k)
+ ! P_Qw_0 : grid scale Cloud drops at time t [kg/kg]
+ P_Qw_0(iklon, klc) = qwHY(i, j, k) / (1.0 - qwHY(i, j, k))
+ !XF bug ?
+ ! P_Qi_0 : grid scale Cloud ice at time t [kg/kg]
+ P_Qi_0(iklon, klc) = qiHY(i, j, k) / (1.0 - qiHY(i, j, k))
+ !XF bug ?
+ ! P_Ua_0 : grid scale hor. wind u at time t [m/s]
+ P_Ua_0(iklon, klc) = uairDY(i, j, k)
+ ! P_Va_0 : grid scale hor. wind v at time t [m/s]
+ P_Va_0(iklon, klc) = vairDY(i, j, k)
+ ! P_Wa_0 : grid scale vertic.wind at time t [m/s]
+ P_Wa_0(iklon, klc) = wairDY(i, j, k) * 0.01 &
+ + sqrt(2.*ect_TE(i, j, k) / 3.)
+#if(AN)
+ P_Wa_0(iklon, klc) = P_Wa_0(iklon, klc) + wANA(i, j, k)
+#endif
+#if(GU)
+ P_Wa_0(iklon, klc) = P_Wa_0(iklon, klc) + waGust(i, j, k)
+#endif
+
+ enddo
+ adj_CA(i, j) = 0.
+
+ if(radsol(i, j) <= 10 .and. tairDY(i, j, mz) <= 283.15 .and. &
+ tairDY(i, j, mz) < (tairDY(i, j, mz - 1) + tairDY(i, j, mz - 2)) / 2.) &
+ MAX_TT(i, j) = -273.15 ! night + inversion + tt < 10 deg
+
+ ! +--Mass Flux convective Scheme: iteration, in case of no vectorization
+ ! + -------------------------------------------------------------------
+
+ if(MAX_TT(i, j) >= min_tt_off) then
+ ! + ***************
+ call CONVECTION( &
+ KLON_0, KLEV_0, kidia0, kfdia0, kbdia0, ktdia0, &
+ pdtCV, Odeep, Oshal, Orset0, Odown0, kIce_0, &
+ OsetA0, PTdcv, PTscv, &
+ kensbl, &
+ P_pa_0, P_za_0, Pdxdy0, &
+ P_Ta_0, P_Qa_0, P_Qw_0, P_Qi_0, P_Ua_0, P_Va_0, P_Wa_0, &
+ Kstep1, PdTa_1, PdQa_1, PdQw_1, PdQi_1, &
+ Pdrr_1, Pdss_1, &
+ PuMF_1, PdMF_1, Pfrr_1, Pfss_1, Pcape1, K_CbT1, K_CbB1, &
+ OCvTC0, KTCCH0, P_CH_0, PdCH_1, P_TKE)
+ ! + ***************
+
+ ! +--Mass Flux convective Scheme: products, in case of no vectorization
+ ! + -------------------------------------------------------------------
+
+ capeCA(i, j) = Pcape1(iklon)
+ adj_CA(i, j) = Kstep1(iklon)
+ drr_CA(i, j) = Pdrr_1(iklon) * dt_loc2
+ dss_CA(i, j) = Pdss_1(iklon) * dt_loc2
+
+ drr_CA(i, j) = max(0., drr_CA(i, j) - dss_CA(i, j))
+ !XF Pdrr_1 = pecip total
+
+ ratio_temp = (tairDY(i, j, mz - 1) + tairDY(i, j, mz - 2) &
+ + tairDY(i, j, mz - 3) + tairDY(i, j, mz - 4)) / 4.
+
+ ratio_prec = drr_CA(i, j)
+
+ ratio_rfsf = max(0., min(1., &
+ (ratio_temp - rain_snow_limit) / 2.))
+
+ drr_CA(i, j) = ratio_prec * ratio_rfsf
+ dss_CA(i, j) = dss_CA(i, j) + ratio_prec * (1.-ratio_rfsf)
+
+ if(isnan(capeCA(i, j))) adj_CA(i, j) = -1
+ if(isnan(drr_CA(i, j))) adj_CA(i, j) = -1
+ if(isnan(dss_CA(i, j))) adj_CA(i, j) = -1
+ if(drr_CA(i, j) > 0.1) adj_CA(i, j) = -1
+ if(drr_CA(i, j) < 0) adj_CA(i, j) = -1
+ if(dss_CA(i, j) > 0.1) adj_CA(i, j) = -1
+ if(dss_CA(i, j) < 0) adj_CA(i, j) = -1
+ if(abs(dpktCA(i, j, k)) > 2) adj_CA(i, j) = -1
+ if(abs(dqv_CA(i, j, k)) > 0.002) adj_CA(i, j) = -1
+
+ do klc = 1, klev
+ k = mzz - klc
+
+ dpktCA(i, j, k) = PdTa_1(iklon, klc) * dt_loc2 / pkDY(i, j, k)
+ dqv_CA(i, j, k) = PdQa_1(iklon, klc) * dt_loc2
+ dqw_CA(i, j, k) = PdQw_1(iklon, klc) * dt_loc2
+ dqi_CA(i, j, k) = PdQi_1(iklon, klc) * dt_loc2
+#if(gu)
+ TaGust(i, j, k) = TaGust(i, j, k) * exp(-dtxLoc * ssvSL(i, j, k)) &
+ + PdTa_1(iklon, klc) * dt_loc2
+ TaGust(i, j, k) = min(TaGust(i, j, k), zero)
+#endif
+ if(isnan(dpktCA(i, j, k))) adj_CA(i, j) = -1
+ if(isnan(dqv_CA(i, j, k))) adj_CA(i, j) = -1
+ if(isnan(dqw_CA(i, j, k))) adj_CA(i, j) = -1
+ if(isnan(dqi_CA(i, j, k))) adj_CA(i, j) = -1
+ enddo
+ endif
+
+ if(adj_CA(i, j) <= 0 .or. MAX_TT(i, j) < min_tt_off) then
+ capeCA(i, j) = 0.
+ drr_CA(i, j) = 0.
+ dss_CA(i, j) = 0.
+ do klc = 1, klev
+ k = mzz - klc
+ dpktCA(i, j, k) = 0.
+ dqv_CA(i, j, k) = 0.
+ dqw_CA(i, j, k) = 0.
+ dqi_CA(i, j, k) = 0.
+ enddo
+ endif
+
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ ! +--Mass Flux convective Scheme: iteration, in case of vectorization
+ ! + -------------------------------------------------------------------
+
+ if(klon > 1) then
+
+ ! + ***************
+ call CONVECTION( &
+ KLON_0, KLEV_0, kidia0, kfdia0, kbdia0, ktdia0, &
+ pdtCV, Odeep, Oshal, Orset0, Odown0, kIce_0, &
+ OsetA0, PTdcv, PTscv, &
+ kensbl, &
+ P_pa_0, P_za_0, Pdxdy0, &
+ P_Ta_0, P_Qa_0, P_Qw_0, P_Qi_0, P_Ua_0, P_Va_0, P_Wa_0, &
+ Kstep1, PdTa_1, PdQa_1, PdQw_1, PdQi_1, &
+ Pdrr_1, Pdss_1, &
+ PuMF_1, PdMF_1, Pfrr_1, Pfss_1, Pcape1, K_CbT1, K_CbB1, &
+ OCvTC0, KTCCH0, P_CH_0, PdCH_1, P_TKE)
+ ! + ***************
+
+ ! +--Mass Flux convective Scheme: products, in case of vectorization
+ ! + -------------------------------------------------------------------
+
+ iklon = 0
+ do j = jp11, my1
+ do i = ip11, mx1
+ iklon = 1 + iklon
+
+ capeCA(i, j) = Pcape1(iklon)
+ adj_CA(i, j) = Kstep1(iklon)
+ drr_CA(i, j) = Pdrr_1(iklon) * dt_loc2
+ dss_CA(i, j) = Pdss_1(iklon) * dt_loc2
+
+ do klc = 1, klev
+ k = mzz - klc
+
+ dpktCA(i, j, k) = PdTa_1(iklon, klc) * dt_loc2 / pkDY(i, j, k)
+ dqv_CA(i, j, k) = PdQa_1(iklon, klc) * dt_loc2
+ dqw_CA(i, j, k) = PdQw_1(iklon, klc) * dt_loc2
+ dqi_CA(i, j, k) = PdQi_1(iklon, klc) * dt_loc2
+#if(GU)
+ TaGust(i, j, k) = TaGust(i, j, k) * exp(-dtxLoc * ssvSL(i, j, k)) &
+ + PdTa_1(iklon, klc) * dt_loc2
+ TaGust(i, j, k) = min(TaGust(i, j, k), zero)
+#endif
+ enddo
+ enddo
+ enddo
+
+ endif
+#if(EW)
+ ! +--Vertical Integrated Energy and Water Content
+ ! + ============================================
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ enr0EW(i, j) = 0.0
+ wat0EW(i, j) = 0.0
+ do k = 1, mz
+ temp_r = pktaDY(i, j, k) * pkDY(i, j, k)
+ enr0EW(i, j) = enr0EW(i, j) &
+ + (temp_r &
+ - (qwHY(i, j, k) + qrHY(i, j, k)) * r_LvCp &
+ - (qiHY(i, j, k) + qsHY(i, j, k)) * r_LsCp) * dsigm1(k)
+ wat0EW(i, j) = wat0EW(i, j) &
+ + (qvDY(i, j, k) &
+ + qwHY(i, j, k) + qrHY(i, j, k) &
+ + qiHY(i, j, k) + qsHY(i, j, k)) * dsigm1(k)
+ enddo
+ enr0EW(i, j) = enr0EW(i, j) * pstDYn(i, j) * grvinv
+ ! wat0EW [m] contains implicit factor 1.d3 [kPa-->Pa] /ro_Wat
+ wat0EW(i, j) = wat0EW(i, j) * pstDYn(i, j) * grvinv
+ energ0 = energ0 - enr0EW(i, j)
+ water0 = water0 - wat0EW(i, j)
+ enddo
+ enddo
+#endif
+
+ ! + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--filtering
+ ! + =========
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ wrk1(i, j, 1) = adj_CA(i, j)
+ wrk1(i, j, 2) = drr_CA(i, j)
+ wrk1(i, j, 3) = dss_CA(i, j)
+ enddo
+ enddo
+
+ call cva_filtering(wrk1, 3)
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(wrk1(i, j, 1) <= 0) then
+ drr_CA(i, j) = 0.
+ dss_CA(i, j) = 0.
+ adj_CA(i, j) = 0.
+ else
+ adj_CA(i, j) = max(1, nint(wrk1(i, j, 1)))
+ drr_CA(i, j) = wrk1(i, j, 2)
+ dss_CA(i, j) = wrk1(i, j, 3)
+ endif
+ enddo
+ enddo
+
+ call cva_filtering(dpktCA, mz)
+ call cva_filtering(dqv_CA, mz)
+ call cva_filtering(dqw_CA, mz)
+ call cva_filtering(dqi_CA, mz)
+
+ endif
+
+ ! +--Mass Flux convective Scheme
+ ! + ===========================
+
+ do j = 6, my - 5
+ do i = 6, mx - 5
+
+ ! + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ locCVA = min(adj_CA(i, j), 1)
+ OK_CVA = max(locCVA, 0)
+ !XF
+ if(adj_CA(i, j) > 0 &
+ .and. max(drr_CA(i, j), dss_CA(i, j)) < 0.25 * dt_loc2 / 3600 &
+ .and. min(drr_CA(i, j), dss_CA(i, j)) >= 0) then
+ ! !MIN= 0 - MAX= 250mm/h
+ OK_CVA = 1.0
+ adj_CA(i, j) = adj_CA(i, j) - 1
+ ! +... ^^^^ Number of remaining time step before the end of convection
+
+ adj_CA(i, j) = max(adj_CA(i, j), 0)
+
+ ! +----Temporal tendencies on pktaDY, qvDY and rainHY
+ ! + ----------------------------------------------
+ DO k = 1, mz
+ pktaDY(i, j, k) = pktaDY(i, j, k) + dpktCA(i, j, k) * OK_CVA
+ qvDY(i, j, k) = max(qvDY(i, j, k) + dqv_CA(i, j, k) * OK_CVA &
+ , epsq)
+ !if(k>=mzhyd) then
+ qwHY(i, j, k) = max(qwHY(i, j, k) + dqw_CA(i, j, k) * OK_CVA, eps9)
+ qiHY(i, j, k) = max(qiHY(i, j, k) + dqi_CA(i, j, k) * OK_CVA, eps9)
+ !end if
+ enddo
+
+ rainHY(i, j) = rainHY(i, j) + drr_CA(i, j) * OK_CVA
+ rainCA(i, j) = rainCA(i, j) + drr_CA(i, j) * OK_CVA
+
+ snowHY(i, j) = snowHY(i, j) + dss_CA(i, j) * OK_CVA
+ snowCA(i, j) = snowCA(i, j) + dss_CA(i, j) * OK_CVA
+ snohSL(i, j) = snohSL(i, j) + dss_CA(i, j) * OK_CVA
+
+ else ! { adj_CA(i,j).gt. 0 }
+
+ do k = 1, mz
+ dpktCA(i, j, k) = 0.
+ dqv_CA(i, j, k) = 0.
+ dqw_CA(i, j, k) = 0.
+ dqi_CA(i, j, k) = 0.
+ enddo
+
+ endif
+
+ ! + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ enddo
+ enddo
+
+#if(EW)
+ ! +--Vertical Integrated Energy and Water Content
+ ! + ============================================
+ do j = jp11, my1
+ do i = ip11, mx1
+ enr1EW(i, j) = 0.0
+ wat1EW(i, j) = 0.0
+ watfEW(i, j) = -drr_CA(i, j)
+ do k = 1, mz
+ temp_r = pktaDY(i, j, k) * pkDY(i, j, k)
+ enr1EW(i, j) = enr1EW(i, j) &
+ + (temp_r &
+ - (qwHY(i, j, k) + qrHY(i, j, k)) * r_LvCp &
+ - (qiHY(i, j, k) + qsHY(i, j, k)) * r_LsCp) * dsigm1(k)
+ wat1EW(i, j) = wat1EW(i, j) &
+ + (qvDY(i, j, k) &
+ + qwHY(i, j, k) + qrHY(i, j, k) &
+ + qiHY(i, j, k) + qsHY(i, j, k)) * dsigm1(k)
+ enddo
+ enr1EW(i, j) = enr1EW(i, j) * pstDYn(i, j) * grvinv &
+ - drr_CA(i, j) * r_LvCp
+ ! wat1EW [m] contains implicit factor 1.d3 [kPa-->Pa] /ro_Wat
+ wat1EW(i, j) = wat1EW(i, j) * pstDYn(i, j) * grvinv
+ energ0 = energ0 + enr1EW(i, j)
+ water0 = water0 + wat1EW(i, j)
+ iter_0 = iter_0 + 1
+ enddo
+ enddo
+#endif
+
+#if(EW)
+ ! +--Vertical Integrated Energy and Water Content: OUTPUT
+ ! + ====================================================
+ irmx = imez
+ jrmx = jmez
+ rr_max = 0.0
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(drr_CA(i, j) > rr_max) then
+ rr_max = drr_CA(i, j)
+ irmx = i
+ jrmx = j
+ endif
+ enddo
+ enddo
+ waterb = wat1EW(irmx, jrmx) - wat0EW(irmx, jrmx) - watfEW(irmx, jrmx)
+ write(6, 606) itexpe, enr0EW(irmx, jrmx), 1.d3 * wat0EW(irmx, jrmx), &
+ irmx, jrmx, enr1EW(irmx, jrmx), 1.d3 * wat1EW(irmx, jrmx), &
+ 1.d3 * watfEW(irmx, jrmx), &
+ 1.d3 * waterb, &
+ energ0 / iter_0, water0 / iter_0
+606 format(i9, ' Before CVAj: E0 =', f12.6, ' W0 = ', f9.6, &
+ /, i5, i4, ' After CVAj: E1 =', f12.6, ' W1 = ', f9.6, &
+ ' W Flux =', f9.6, &
+ ' Div(W) =', e9.3, &
+ /, 9x, ' Mean dE =', f12.9, ' dW = ', e9.3)
+#endif
+
+ iitCV0 = iitCV0 + 1
+
+ return
+endsubroutine CVAgen_MNH
diff --git a/MAR/code_mar/cvamnh.f90 b/MAR/code_mar/cvamnh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f461770af8711c44a18e0222d7fa2c3c866b3f61
--- /dev/null
+++ b/MAR/code_mar/cvamnh.f90
@@ -0,0 +1,9446 @@
+MODULE MODD_CONVPAR_SHAL
+! ########################
+!
+!!**** *MODD_CONVPAR_SHAL* - Declaration of convection constants
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this declarative module is to declare the
+!! constants in the deep convection parameterization.
+!!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (MODD_CONVPAR_SHAL)
+!!
+!! AUTHOR
+!! ------
+!! P. Bechtold *Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 04/10/98
+!! E. Bazile 05/05/09
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ implicit none
+!
+ REAL, SAVE :: XA25 ! 25 km x 25 km reference grid area
+!
+ REAL, SAVE :: XCRAD ! cloud radius
+ REAL, SAVE :: XCTIME_SHAL ! convective adjustment time
+ REAL, SAVE :: XCDEPTH ! minimum necessary cloud depth
+ REAL, SAVE :: XCDEPTH_D ! maximum allowed cloud thickness
+ REAL, SAVE :: XDTPERT ! add small Temp perturb. at LCL
+ REAL, SAVE :: XATPERT ! Parameter for temp Perturb
+ REAL, SAVE :: XBTPERT ! Parameter for temp Perturb
+ ! (XATPERT* TKE/Cp + XBTPERT) * XDTPERT
+ REAL, SAVE :: XENTR ! entrainment constant (m/Pa) = 0.2 (m)
+!
+ REAL, SAVE :: XZLCL ! maximum allowed allowed height
+ ! difference between departure level and surface
+ REAL, SAVE :: XZPBL ! minimum mixed layer depth to sustain convection
+ REAL, SAVE :: XWTRIG ! constant in vertical velocity trigger
+!
+!
+ REAL, SAVE :: XNHGAM ! accounts for non-hydrost. pressure
+ ! in buoyancy term of w equation
+ ! = 2 / (1+gamma)
+ REAL, SAVE :: XTFRZ1 ! begin of freezing interval
+ REAL, SAVE :: XTFRZ2 ! end of freezing interval
+!
+!
+ REAL, SAVE :: XSTABT ! factor to assure stability in fractional time
+ ! integration, routine CONVECT_CLOSURE
+ REAL, SAVE :: XSTABC ! factor to assure stability in CAPE adjustment,
+ ! routine CONVECT_CLOSURE
+ REAL, SAVE :: XAW, XBW ! Parameters for WLCL = XAW * W + XBW
+ LOGICAL, SAVE :: LLSMOOTH ! Default=TRUE but not necessary
+!$OMP threadprivate(XA25,XCRAD,XCTIME_SHAL,XCDEPTH,XCDEPTH_D,XDTPERT,XATPERT, &
+!$OMP XENTR,XZLCL,XZPBL,XWTRIG,XNHGAM,XTFRZ1,XTFRZ2,XSTABT,XSTABC, &
+!$OMP XAW,XBW ,LLSMOOTH)
+ENDMODULE MODD_CONVPAR_SHAL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+MODULE MODD_CONVPAR
+! ###################
+!
+!!**** *MODD_CONVPAR* - Declaration of convection constants
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the
+! constants in the deep convection parameterization.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (MODD_CONVPAR)
+!!
+!! AUTHOR
+!! ------
+!! P. Bechtold *Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 15/11/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ implicit none
+!
+ REAL, SAVE :: XA25 ! 25 km x 25 km reference grid area
+!
+ REAL, SAVE :: XCRAD ! cloud radius
+ REAL, SAVE :: XCDEPTH ! minimum necessary cloud depth
+ REAL, SAVE :: XENTR ! entrainment constant (m/Pa) = 0.2 (m)
+!
+ REAL, SAVE :: XZLCL ! maximum allowed allowed height
+ ! difference between departure level and surface
+ REAL, SAVE :: XZPBL ! minimum mixed layer depth to sustain convection
+ REAL, SAVE :: XWTRIG ! constant in vertical velocity trigger
+!
+!
+ REAL, SAVE :: XNHGAM ! accounts for non-hydrost. pressure
+ ! in buoyancy term of w equation
+ ! = 2 / (1+gamma)
+ REAL, SAVE :: XTFRZ1 ! begin of freezing interval
+ REAL, SAVE :: XTFRZ2 ! end of freezing interval
+!
+ REAL, SAVE :: XRHDBC ! relative humidity below cloud in downdraft
+!
+ REAL, SAVE :: XRCONV ! constant in precipitation conversion
+ REAL, SAVE :: XSTABT ! factor to assure stability in fractional time
+ ! integration, routine CONVECT_CLOSURE
+ REAL, SAVE :: XSTABC ! factor to assure stability in CAPE adjustment,
+ ! routine CONVECT_CLOSURE
+ REAL, SAVE :: XUSRDPTH ! pressure thickness used to compute updraft
+ ! moisture supply rate for downdraft
+ REAL, SAVE :: XMELDPTH ! layer (Pa) through which precipitation melt is
+ ! allowed below melting level
+ REAL, SAVE :: XUVDP ! constant for pressure perturb in momentum transport
+!$OMP threadprivate(XA25,XCRAD,XCDEPTH,XENTR,XZLCL,XZPBL,XWTRIG,XNHGAM,XTFRZ1, &
+!$OMP XTFRZ2,XRHDBC,XRCONV,XSTABT,XSTABC,XUSRDPTH,XMELDPTH,XUVDP)
+ENDMODULE MODD_CONVPAR
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #####################
+MODULE MODI_INI_CONVPAR_E1
+! #####################
+!
+ INTERFACE
+!
+ subroutine INI_CONVPAR_E1
+ ENDsubroutine INI_CONVPAR_E1
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_INI_CONVPAR_E1
+!
+!
+! #########################
+subroutine INI_CONVPAR_E1
+! #########################
+!
+!!**** *INI_CONVPAR * - routine to initialize the convective constants modules
+!! with modifications for ensemble run.
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to initialize the constants
+! stored in modules MODD_CONVPAR, MODD_CST, MODD_CONVPAREXT.
+!
+!
+!!** METHOD
+!! ------
+!! The deep convection constants are set to their numerical values
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONVPAR : contains deep convection constants
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation (module MODD_CONVPAR, routine INI_CONVPAR)
+!!
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 15/04/98 adapted for ARPEGE
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAR
+!
+ implicit none
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Set the thermodynamical and numerical constants for
+! the deep convection parameterization
+! ---------------------------------------------------
+!
+!
+ XA25 = 100.E6 ! 25 km x 25 km reference grid area
+!
+ XCRAD = 500. ! cloud radius
+ XCDEPTH = 3.E3 ! minimum necessary cloud depth
+ XENTR = 0.03 ! entrainment constant (m/Pa) = 0.2 (m)
+!
+ XZLCL = 3.5E3 ! maximum allowed allowed height
+ ! difference between the surface and the LCL
+ XZPBL = 60.E2 ! minimum mixed layer depth to sustain convection
+ XWTRIG = 6.00 ! constant in vertical velocity trigger
+!
+!
+ XNHGAM = 1.3333 ! accounts for non-hydrost. pressure
+ ! in buoyancy term of w equation
+ ! = 2 / (1+gamma)
+ XTFRZ1 = 268.16 ! begin of freezing interval
+ XTFRZ2 = 248.16 ! end of freezing interval
+!
+ XRHDBC = 0.9 ! relative humidity below cloud in downdraft
+
+ XRCONV = 0.015 ! constant in precipitation conversion
+ XSTABT = 0.75 ! factor to assure stability in fractional time
+ ! integration, routine CONVECT_CLOSURE
+ XSTABC = 0.95 ! factor to assure stability in CAPE adjustment,
+ ! routine CONVECT_CLOSURE
+ XUSRDPTH = 165.E2 ! pressure thickness used to compute updraft
+ ! moisture supply rate for downdraft
+ XMELDPTH = 200.E2 ! layer (Pa) through which precipitation melt is
+ ! allowed below downdraft
+ XUVDP = 0.7 ! constant for pressure perturb in momentum transport
+!
+!
+ENDsubroutine INI_CONVPAR_E1
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 init 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #####################
+MODULE MODI_INI_CONVPAR
+! #####################
+!
+ INTERFACE
+!
+ subroutine INI_CONVPAR
+ ENDsubroutine INI_CONVPAR
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_INI_CONVPAR
+!
+!
+!
+! ######################
+subroutine INI_CONVPAR
+! ######################
+!
+!!**** *INI_CONVPAR * - routine to initialize the constants modules
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to initialize the constants
+! stored in modules MODD_CONVPAR, MODD_CST, MODD_CONVPAREXT.
+!
+!
+!!** METHOD
+!! ------
+!! The deep convection constants are set to their numerical values
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONVPAR : contains deep convection constants
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation (module MODD_CONVPAR, routine INI_CONVPAR)
+!!
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 15/04/98 adapted for ARPEGE
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAR
+!
+ implicit none
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Set the thermodynamical and numerical constants for
+! the deep convection parameterization
+! ---------------------------------------------------
+!
+!
+ XA25 = 625.E6 ! 25 km x 25 km reference grid area
+!
+ XCRAD = 1500. ! cloud radius
+ XCDEPTH = 2.5E3 ! minimum necessary cloud depth
+ XENTR = 0.03 ! entrainment constant (m/Pa) = 0.2 (m)
+!
+ XZLCL = 3.5E3 ! maximum allowed allowed height
+ ! difference between the surface and the LCL
+ XZPBL = 60.E2 ! minimum mixed layer depth to sustain convection
+ XWTRIG = 6.00 ! constant in vertical velocity trigger
+!
+!
+ XNHGAM = 1.3333 ! accounts for non-hydrost. pressure
+ ! in buoyancy term of w equation
+ ! = 2 / (1+gamma)
+ XTFRZ1 = 268.16 ! begin of freezing interval
+ XTFRZ2 = 248.16 ! end of freezing interval
+!
+ XRHDBC = 0.9 ! relative humidity below cloud in downdraft
+
+ XRCONV = 0.015 ! constant in precipitation conversion
+ XSTABT = 0.75 ! factor to assure stability in fractional time
+ ! integration, routine CONVECT_CLOSURE
+ XSTABC = 0.95 ! factor to assure stability in CAPE adjustment,
+ ! routine CONVECT_CLOSURE
+ XUSRDPTH = 165.E2 ! pressure thickness used to compute updraft
+ ! moisture supply rate for downdraft
+ XMELDPTH = 100.E2 ! layer (Pa) through which precipitation melt is
+ ! allowed below downdraft
+ XUVDP = 0.7 ! constant for pressure perturb in momentum transport
+!
+!
+ENDsubroutine INI_CONVPAR
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 init 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #####################
+MODULE MODI_INI_CONVPAR_SHAL
+! #####################
+!
+ INTERFACE
+!
+ subroutine INI_CONVPAR_SHAL
+ ENDsubroutine INI_CONVPAR_SHAL
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_INI_CONVPAR_SHAL
+!
+!
+! ###########################
+subroutine INI_CONVPAR_SHAL
+! ###########################
+!
+!!**** *INI_CONVPAR * - routine to initialize the constants modules
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to initialize the constants
+!! stored in modules MODD_CONVPAR_SHAL
+!!
+!!
+!!** METHOD
+!! ------
+!! The shallow convection constants are set to their numerical values
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONVPAR_SHAL : contains deep convection constants
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation (module MODD_CONVPAR_SHAL, routine INI_CONVPAR)
+!!
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 15/04/98 adapted for ARPEGE
+!! 05/05/09 E. Bazile
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAR_SHAL
+!
+ implicit none
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Set the thermodynamical and numerical constants for
+! the deep convection parameterization
+! ---------------------------------------------------
+!
+!
+ XA25 = 625.E6 ! 25 km x 25 km reference grid area
+!
+ XCRAD = 50. ! cloud radius
+ XCTIME_SHAL = 10800. ! convective adjustment time
+ XCDEPTH = 0.5E3 ! minimum necessary shallow cloud depth
+ XCDEPTH_D = 2.5E3 ! maximum allowed shallow cloud depth
+ XDTPERT = .2 ! add small Temp perturbation at LCL
+ XATPERT = 0. ! 0.=original scheme , recommended = 1000.
+ XBTPERT = 1. ! 1.=original scheme , recommended = 0.
+!
+ XENTR = 0.02 ! entrainment constant (m/Pa) = 0.2 (m)
+!
+ XZLCL = 0.5E3 ! maximum allowed allowed height
+ ! difference between the DPL and the surface
+ XZPBL = 40.E2 ! minimum mixed layer depth to sustain convection
+!
+!
+ XNHGAM = 1.3333 ! accounts for non-hydrost. pressure
+ ! in buoyancy term of w equation
+ ! = 2 / (1+gamma)
+ XTFRZ1 = 268.16 ! begin of freezing interval
+ XTFRZ2 = 248.16 ! end of freezing interval
+!
+
+ XSTABT = 0.75 ! factor to assure stability in fractional time
+ ! integration, routine CONVECT_CLOSURE
+ XSTABC = 0.95 ! factor to assure stability in CAPE adjustment,
+ ! routine CONVECT_CLOSURE
+ XAW = 0. ! 0.= Original scheme , 1 = recommended
+ XBW = 1. ! 1.= Original scheme , 0 = recommended
+ LLSMOOTH = .true.
+!
+!
+ENDsubroutine INI_CONVPAR_SHAL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+! ######spl
+subroutine CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, ODEEP, OSHAL, OREFRESH_ALL, ODOWN, KICE, &
+ OSETTADJ, PTADJD, PTADJS, &
+ KENSM, &
+ PPABS, PZZ, PDXDY, &
+ PT, PRV, PRC, PRI, PU, PV, PW, &
+ KCOUNT, PTTEN, PRVTEN, PRCTEN, PRITEN, &
+ PPRTEN, PPRSTEN, &
+ PUMF, PDMF, PPRLFLX, PPRSFLX, PCAPE, KCLTOP, KCLBAS, &
+ OCHTRANS, KCH1, PCH1, PCH1TEN, &
+ SeBi_TKE)
+! ############################################################################
+!
+!!**** Interface routine to the fast MNH convection code developed for ECMWF/ARPEGE IFS
+!! having a structure typical for operational routines
+!!
+!!
+!! PURPOSE
+!! -------
+!! The routine interfaces the MNH convection code as developed for operational
+!! forecast models like ECMWF, ARPEGE or HIRLAM with the typical MNH array structure
+!! Calls the deep and/or shallow convection routine
+!!
+!!
+!!** METHOD
+!! ------
+!! Returns one tendency for shallow+deep convection but each part can
+!! be activated/desactivated separately.
+!! For deep convection one can enable up to 3 additional ensemble members
+!! - this substantially improves the smoothness of the scheme and
+!! allows for runs with different cloud radii (entrainment rates) and
+!! reduces the arbitrariness inherent to convective trigger condition
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! CONVECT_DEEP
+!! CONVECT_SHALLOW
+!! INI_CONVPAR, INI_CONVPAR1
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/12/98
+!! Modif 11/04/O2 allow for ensemble of deep updrafts/downdrafts
+!!
+!! REFERENCE
+!! ---------
+!! Bechtold et al., 2001, Quart. J. Roy. Meteor. Soc., Vol 127, pp 869-886:
+!! A mass flux convection scheme for regional and global models.
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KIDIA ! value of the first point in x
+ INTEGER, INTENT(IN) :: KFDIA ! value of the last point in x
+ INTEGER, INTENT(IN) :: KBDIA ! vertical computations start at
+! ! KBDIA that is at least 1
+ INTEGER, INTENT(IN) :: KTDIA ! vertical computations can be
+ ! limited to KLEV + 1 - KTDIA
+ ! default=1
+ REAL, INTENT(IN) :: PDTCONV ! Interval of time between two
+ ! calls of the deep convection
+ ! scheme
+ LOGICAL, INTENT(IN) :: ODEEP ! switch for deep convection
+ LOGICAL, INTENT(IN) :: OSHAL ! switch for shallow convection
+ LOGICAL, INTENT(IN) :: OREFRESH_ALL ! refresh or not all
+ ! tendencies at every call
+ LOGICAL, INTENT(IN) :: ODOWN ! take or not convective
+ ! downdrafts into account
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ INTEGER, INTENT(IN) :: KENSM ! number of additional deep convection calls
+ ! for ensemble (presently limited to 3)
+ ! KENSM=0 corresponds to base run with
+ ! 1 deep and 1 shallow call
+ LOGICAL, INTENT(IN) :: OSETTADJ ! logical to set convective
+ ! adjustment time by user
+ REAL, INTENT(IN) :: PTADJD ! user defined deep adjustment time (s)
+ REAL, INTENT(IN) :: PTADJS ! user defined shal. adjustment time (s)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PT ! grid scale T at time t (K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! grid scale water vapor (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PU ! grid scale horiz. wind u (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PV ! grid scale horiz. wind v (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PW ! grid scale vertical velocity (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPABS ! grid scale pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m2)
+
+!
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCOUNT ! convective counter(recompute
+ ! tendency or keep it
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PTTEN ! convective temperat. tendency (K/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRVTEN ! convective r_v tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRCTEN ! convective r_c tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRITEN ! convective r_i tendency (1/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRTEN ! total surf precipitation tendency (m/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRSTEN! solid surf precipitation tendency (m/s)
+!
+! Chemical Tracers:
+ LOGICAL, INTENT(IN) :: OCHTRANS ! flag to compute convective
+ ! transport for chemical tracer
+ INTEGER, INTENT(IN) :: KCH1 ! number of species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(IN) :: PCH1 ! grid scale chemical species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(INOUT):: PCH1TEN ! chemical convective tendency
+ ! (1/s)
+!
+! Diagnostic variables:
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s m2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDMF ! downdraft mass flux (kg/s m2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PPRLFLX! liquid precip flux (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PPRSFLX! solid precip flux (m/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PCAPE ! CAPE (J/kg)
+ INTEGER, DIMENSION(KLON), INTENT(INOUT) :: KCLTOP ! cloud top level (number of model level)
+ INTEGER, DIMENSION(KLON), INTENT(INOUT) :: KCLBAS ! cloud base level(number of model level)
+ ! they are given a value of
+ ! 0 if no convection
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: JI, JK, JN ! loop index
+!
+ REAL, DIMENSION(KLON) :: ZTIMEC, ZPRLTEN
+!
+! special for shallow convection
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTTENS, ZRVTENS, ZRCTENS, ZRITENS, &
+ ZUMFS
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZCH1TENS
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ICLBASS, ICLTOPS
+!
+!* 0.3 Declarations of additional Ensemble fields:
+!
+ integer :: KENS ! number of allowed additional deep convection calls
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZTTENE ! convective temperat. tendency (K/s)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZRVTENE ! convective r_v tendency (1/s)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZRCTENE ! convective r_c tendency (1/s)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZRITENE ! convective r_i tendency (1/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZPRLTENE ! liquid surf precipitation tendency (m/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZPRSTENE ! solid surf precipitation tendency (m/s)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZUMFE ! updraft mass flux (kg/s m2)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZDMFE ! downdraft mass flux (kg/s m2)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZPRLFLXE ! liquid precip flux (m/s)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE :: ZPRSFLXE ! solid precip flux (m/s)
+ REAL, DIMENSION(:, :, :, :), ALLOCATABLE:: ZCH1TENE ! chemical convective tendency
+ INTEGER, DIMENSION(:, :), ALLOCATABLE :: ICLTOPE ! cloud top level (number of model level)
+ INTEGER, DIMENSION(:, :), ALLOCATABLE :: ICLBASE ! cloud base level(number of model level)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZEDUMMY ! field not to be recomputed by ensemble
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IEDUMMY ! field not to be recomputed by ensemble
+ REAL, DIMENSION(:), ALLOCATABLE :: ZWEIGHT ! weighting factor for ensemble members
+ real :: ZSUM ! sum of weighting factors
+
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: SeBi_TKE ! TKE
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 0.5 Allocate 2D (horizontal, vertical) arrays and additional ensemble arrays
+! ------------------------------------------------------------------------
+!
+ ALLOCATE(ZTTENS(KLON, KLEV)); ALLOCATE(ZRVTENS(KLON, KLEV))
+ ALLOCATE(ZRCTENS(KLON, KLEV)); ALLOCATE(ZRITENS(KLON, KLEV))
+ ALLOCATE(ZCH1TENS(KLON, KLEV, KCH1))
+ ALLOCATE(ZUMFS(KLON, KLEV))
+ ALLOCATE(ICLBASS(KLON)); ALLOCATE(ICLTOPS(KLON))
+!
+ KCLTOP(:) = 1 ! set default value when no convection
+ KCLBAS(:) = 1 ! can be changed depending on user
+ ICLTOPS(:) = 1
+ ICLBASS(:) = 1
+!
+ KENS = MIN(KENSM, 3)
+ if(KENS > 0) then
+ ALLOCATE(ZTTENE(KLON, KLEV, KENS))
+ ALLOCATE(ZRVTENE(KLON, KLEV, KENS))
+ ALLOCATE(ZRCTENE(KLON, KLEV, KENS))
+ ALLOCATE(ZRITENE(KLON, KLEV, KENS))
+ ALLOCATE(ZUMFE(KLON, KLEV, KENS))
+ ALLOCATE(ZDMFE(KLON, KLEV, KENS))
+ ALLOCATE(ZCH1TENE(KLON, KLEV, KCH1, KENS))
+ ALLOCATE(ZPRLFLXE(KLON, KLEV, KENS))
+ ALLOCATE(ZPRSFLXE(KLON, KLEV, KENS))
+ ALLOCATE(ZPRLTENE(KLON, KENS))
+ ALLOCATE(ZPRSTENE(KLON, KENS))
+ ALLOCATE(ICLTOPE(KLON, KENS))
+ ALLOCATE(ICLBASE(KLON, KENS))
+ ALLOCATE(ZEDUMMY(KLON))
+ ALLOCATE(IEDUMMY(KLON))
+ ALLOCATE(ZWEIGHT(KENS))
+ endif
+!
+!* 4.a Call deep convection routine
+! ----------------------------
+!
+ if(ODEEP) then
+!
+! 1. Base version
+!
+ call INI_CONVPAR
+!
+ if(OSETTADJ) ZTIMEC(:) = PTADJD
+
+!
+
+!print*, "PRV beg",MAXVAL(PTTEN),MAXVAL(PRVTEN),MAXVAL(PRCTEN),MAXVAL(PRITEN)
+ call DEEP_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OREFRESH_ALL, ODOWN, OSETTADJ, &
+ PPABS, PZZ, PDXDY, ZTIMEC, &
+ PT, PRV, PRC, PRI, PU, PV, PW, &
+ KCOUNT, PTTEN, PRVTEN, PRCTEN, PRITEN, &
+ ZPRLTEN, PPRSTEN, &
+ KCLTOP, KCLBAS, PPRLFLX, PPRSFLX, &
+ PUMF, PDMF, PCAPE, &
+ OCHTRANS, KCH1, PCH1, PCH1TEN)
+!
+! 2. Additional Ensemble members
+!
+ if(KENS > 0) then
+!
+ call INI_CONVPAR_E1
+!
+!* first member - changes in MODD_CONVPAR (cloud radius of 500 m or so)
+! specified in INI_CONVPAR1
+!
+ call DEEP_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OREFRESH_ALL, ODOWN, OSETTADJ, &
+ PPABS, PZZ, PDXDY, ZTIMEC, &
+ PT, PRV, PRC, PRI, PU, PV, PW, &
+ IEDUMMY, ZTTENE(:, :, 1), ZRVTENE(:, :, 1), ZRCTENE(:, :, 1), ZRITENE(:, :, 1), &
+ ZPRLTENE(:, 1), ZPRSTENE(:, 1), &
+ ICLTOPE(:, 1), ICLBASE(:, 1), ZPRLFLXE(:, :, 1), ZPRSFLXE(:, :, 1), &
+ ZUMFE(:, :, 1), ZDMFE(:, :, 1), ZEDUMMY, &
+ OCHTRANS, KCH1, PCH1, ZCH1TENE(:, :, :, 1))
+ endif
+!
+ if(KENS > 1) then
+!
+ call INI_CONVPAR
+!
+!* second member (positive vertical velocity perturb for Trigger)
+!
+ call DEEP_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OREFRESH_ALL, ODOWN, OSETTADJ, &
+ PPABS, PZZ, PDXDY, ZTIMEC, &
+ PT, PRV, PRC, PRI, PU, PV, PW * 1.5 + 1.e-4, &
+ IEDUMMY, ZTTENE(:, :, 2), ZRVTENE(:, :, 2), ZRCTENE(:, :, 2), ZRITENE(:, :, 2), &
+ ZPRLTENE(:, 2), ZPRSTENE(:, 2), &
+ ICLTOPE(:, 2), ICLBASE(:, 2), ZPRLFLXE(:, :, 2), ZPRSFLXE(:, :, 2), &
+ ZUMFE(:, :, 2), ZDMFE(:, :, 2), ZEDUMMY, &
+ OCHTRANS, KCH1, PCH1, ZCH1TENE(:, :, :, 2))
+ endif
+!
+ if(KENS > 2) then
+!
+!* third member (negative vertical velocity perturb for Trigger)
+!
+ call DEEP_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OREFRESH_ALL, ODOWN, OSETTADJ, &
+ PPABS, PZZ, PDXDY, ZTIMEC, &
+ PT, PRV, PRC, PRI, PU, PV, PW*.5 - 1.e-4, &
+ IEDUMMY, ZTTENE(:, :, 3), ZRVTENE(:, :, 3), ZRCTENE(:, :, 3), ZRITENE(:, :, 3), &
+ ZPRLTENE(:, 3), ZPRSTENE(:, 3), &
+ ICLTOPE(:, 3), ICLBASE(:, 3), ZPRLFLXE(:, :, 3), ZPRSFLXE(:, :, 3), &
+ ZUMFE(:, :, 3), ZDMFE(:, :, 3), ZEDUMMY, &
+ OCHTRANS, KCH1, PCH1, ZCH1TENE(:, :, :, 3))
+ endif
+!
+!print*, "PRV end",MAXVAL(PTTEN),MAXVAL(PRVTEN),MAXVAL(PRCTEN),MAXVAL(PRITEN)
+ endif
+ if(.not. ODEEP) then
+ KCOUNT(:) = 0
+ PTTEN(:, :) = 0.
+ PRVTEN(:, :) = 0.
+ PRCTEN(:, :) = 0.
+ PRITEN(:, :) = 0.
+ PUMF(:, :) = 0.
+ PDMF(:, :) = 0.
+ ! KCLTOP(:) =1
+ ! KCLBAS(:) =1
+ PCH1TEN(:, :, :) = 0.
+ ZPRLTEN(:) = 0.
+ PPRSTEN(:) = 0.
+ PPRLFLX(:, :) = 0.
+ PPRSFLX(:, :) = 0.
+ PCAPE(:) = 0.
+ endif
+
+!
+!* 4.b Call shallow convection routine
+! -------------------------------
+!
+ if(OSHAL) then
+!
+ if(.not. ODEEP) call INI_CONVPAR
+ call INI_CONVPAR_SHAL
+!
+ call SHALLOW_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OSETTADJ, PTADJS, &
+ PPABS, PZZ, SeBi_TKE(:, KBDIA + 1), &
+ PT, PRV, PRC, PRI, PW, &
+ ZTTENS, ZRVTENS, ZRCTENS, ZRITENS, &
+ ICLTOPS, ICLBASS, ZUMFS, &
+ OCHTRANS, KCH1, PCH1, ZCH1TENS)
+ endif
+ if(.not. OSHAL) then
+ ZTTENS(:, :) = 0.
+ ZRVTENS(:, :) = 0.
+ ZRCTENS(:, :) = 0.
+ ZRITENS(:, :) = 0.
+ ZUMFS(:, :) = 0
+ ! ICLTOPS(:) =1
+ ! ICLBASS(:) =1
+ ZCH1TENS(:, :, :) = 0.
+ endif
+!
+!* 5. Add - if activated - ensemble average values for deep
+! and then shallow convective tendencies
+! ---------------------------------------------------------
+!
+ ZSUM = 1.
+ if(KENS > 0) then
+ if(KENS == 1) ZWEIGHT(:) = .5
+ if(KENS > 1) ZWEIGHT(:) = 1.
+ do JN = 1, KENS
+ PTTEN(:, :) = PTTEN(:, :) + ZWEIGHT(JN) * ZTTENE(:, :, JN)
+ PRVTEN(:, :) = PRVTEN(:, :) + ZWEIGHT(JN) * ZRVTENE(:, :, JN)
+ PRCTEN(:, :) = PRCTEN(:, :) + ZWEIGHT(JN) * ZRCTENE(:, :, JN)
+ PRITEN(:, :) = PRITEN(:, :) + ZWEIGHT(JN) * ZRITENE(:, :, JN)
+ PPRLFLX(:, :) = PPRLFLX(:, :) + ZWEIGHT(JN) * ZPRLFLXE(:, :, JN)
+ PPRSFLX(:, :) = PPRSFLX(:, :) + ZWEIGHT(JN) * ZPRSFLXE(:, :, JN)
+ PUMF(:, :) = PUMF(:, :) + ZWEIGHT(JN) * ZUMFE(:, :, JN)
+ PDMF(:, :) = PDMF(:, :) + ZWEIGHT(JN) * ZDMFE(:, :, JN)
+ ZPRLTEN(:) = ZPRLTEN(:) + ZWEIGHT(JN) * ZPRLTENE(:, JN)
+ PPRSTEN(:) = PPRSTEN(:) + ZWEIGHT(JN) * ZPRSTENE(:, JN)
+ KCLTOP(:) = MAX(KCLTOP(:), ICLTOPE(:, JN))
+ KCLBAS(:) = MAX(KCLBAS(:), ICLBASE(:, JN))
+ if(OCHTRANS) &
+ & PCH1TEN(:, :, :) = PCH1TEN(:, :, :) + ZWEIGHT(JN) * ZCH1TENE(:, :, :, JN)
+ enddo
+!
+ ZSUM = 1./(1.+SUM(ZWEIGHT(:)))
+ endif
+!
+ PTTEN(:, :) = PTTEN(:, :) * ZSUM + ZTTENS(:, :)
+ PRVTEN(:, :) = PRVTEN(:, :) * ZSUM + ZRVTENS(:, :)
+ PRCTEN(:, :) = PRCTEN(:, :) * ZSUM + ZRCTENS(:, :)
+ PRITEN(:, :) = PRITEN(:, :) * ZSUM + ZRITENS(:, :)
+ PPRLFLX(:, :) = PPRLFLX(:, :) * ZSUM
+ PPRSFLX(:, :) = PPRSFLX(:, :) * ZSUM
+ PUMF(:, :) = PUMF(:, :) * ZSUM + ZUMFS(:, :)
+ PDMF(:, :) = PDMF(:, :) * ZSUM
+ PPRTEN(:) = (ZPRLTEN(:) + PPRSTEN(:)) * ZSUM
+ PPRSTEN(:) = PPRSTEN(:) * ZSUM
+ KCLTOP(:) = MAX(KCLTOP(:), ICLTOPS(:))
+ KCLBAS(:) = MAX(KCLBAS(:), ICLBASS(:))
+ if(OCHTRANS) then
+ PCH1TEN(:, :, :) = PCH1TEN(:, :, :) * ZSUM + ZCH1TENS(:, :, :)
+ endif
+!
+!* 6. Deallocate local arrays
+!
+ DEALLOCATE(ICLBASS); DEALLOCATE(ICLTOPS)
+ DEALLOCATE(ZUMFS)
+ DEALLOCATE(ZCH1TENS)
+ DEALLOCATE(ZRCTENS); DEALLOCATE(ZRITENS)
+ DEALLOCATE(ZTTENS); DEALLOCATE(ZRVTENS)
+
+ if(KENS > 0) then
+ DEALLOCATE(ZTTENE); DEALLOCATE(ZRVTENE)
+ DEALLOCATE(ZRCTENE); DEALLOCATE(ZRITENE)
+ DEALLOCATE(ZUMFE); DEALLOCATE(ZDMFE)
+ DEALLOCATE(ZCH1TENE)
+ DEALLOCATE(ZPRLFLXE); DEALLOCATE(ZPRSFLXE)
+ DEALLOCATE(ZPRLTENE); DEALLOCATE(ZPRSTENE)
+ DEALLOCATE(ZEDUMMY); DEALLOCATE(IEDUMMY)
+ DEALLOCATE(ZWEIGHT)
+! XF BUG BUG 26/09/2016
+ DEALLOCATE(ICLTOPE)
+ DEALLOCATE(ICLBASE)
+! XF BUG BUG
+ endif
+!
+!
+ENDsubroutine CONVECTION
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 modd 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ###############
+MODULE MODD_CST
+! ###############
+!
+!!**** *MODD_CST* - declaration of Physic constants
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the
+! Physics constants.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (MODD_CST)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/05/94
+!! J. Stein 02/01/95 add xrholw
+!! J.-P. Pinty 13/12/95 add XALPI,XBETAI,XGAMI
+!! J. Stein 25/07/97 add XTH00
+!! V. Masson 05/10/98 add XRHOLI
+!! C. Mari 31/10/00 add NDAYSEC
+!! V. Masson 01/03/03 add conductivity of ice
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ implicit none
+ REAL, PARAMETER :: XPI = 2.*ASIN(1.) ! Pi
+!
+ REAL, PARAMETER :: XDAY = 86400.
+ REAL, PARAMETER :: XSIYEA = 365.25 * XDAY * 2.*XPI / 6.283076
+ REAL, PARAMETER :: XSIDAY = XDAY / (1.+XDAY / XSIYEA) ! day duration, sideral year duration,
+ ! sideral day duration
+!
+ REAL, PARAMETER :: XKARMAN = 0.4 ! von karman constant
+ REAL, PARAMETER :: XLIGHTSPEED = 299792458. ! light speed
+ REAL, PARAMETER :: XPLANCK = 6.6260755E-34 ! Planck constant
+ REAL, PARAMETER :: XBOLTZ = 1.380658E-23 ! Boltzman constant
+ REAL, PARAMETER :: XAVOGADRO = 6.0221367E+23 ! Avogadro number
+!
+ REAL, PARAMETER :: XRADIUS = 6371229.
+ REAL, PARAMETER :: XOMEGA = 2.*XPI / XSIDAY ! Earth radius, earth rotation
+ REAL, PARAMETER :: XG = 9.80665 ! Gravity constant
+!
+ REAL, PARAMETER :: XP00 = 1.E5 ! Reference pressure
+!
+ REAL, PARAMETER :: XSTEFAN = (2.*XPI**5 / 15.) * ((XBOLTZ / XPLANCK) * XBOLTZ) * (XBOLTZ / (XLIGHTSPEED * XPLANCK))**2
+ REAL, PARAMETER :: XI0 = 1370. ! Stefan-Boltzman constant, solar constant
+!
+ REAL, PARAMETER :: XMD = 28.9644E-3
+ REAL, PARAMETER :: XMV = 18.0153E-3 ! Molar mass of dry air and molar mass of vapor
+ REAL, PARAMETER :: XRD = XAVOGADRO * XBOLTZ / XMD
+ REAL, PARAMETER :: XRV = XAVOGADRO * XBOLTZ / XMV ! Gaz constant for dry air, gaz constant for vapor
+ REAL, PARAMETER :: XCPD = 7.*XRD / 2.
+ REAL, PARAMETER :: XCPV = 4.*XRV ! Cpd (dry air), Cpv (vapor)
+ REAL, PARAMETER :: XRHOLW = 1000. ! Volumic mass of liquid water
+ REAL, PARAMETER :: XCL = 4.218E+3
+ REAL, PARAMETER :: XCI = 2.106E+3 ! Cl (liquid), Ci (ice)
+ REAL, PARAMETER :: XTT = 273.16 ! Triple point temperature
+ REAL, PARAMETER :: XLVTT = 2.5008E+6 ! Vaporization heat constant
+ REAL, PARAMETER :: XLSTT = 2.8345E+6 ! Sublimation heat constant
+ REAL, PARAMETER :: XLMTT = XLSTT - XLVTT ! Melting heat constant
+ REAL, PARAMETER :: XESTT = 611.14 ! Saturation vapor pressure at triple point
+ ! temperature
+ REAL, PARAMETER :: XGAMW = (XCL - XCPV) / XRV ! Constants for saturation vapor pressure function
+ REAL, PARAMETER :: XBETAW = (XLVTT / XRV) + (XGAMW * XTT)
+ REAL, PARAMETER :: XALPW = LOG(XESTT) + (XBETAW / XTT) + (XGAMW * LOG(XTT))
+!
+ REAL, PARAMETER :: XGAMI = (XCI - XCPV) / XRV ! Constants for saturation vapor pressure function over solid ice
+ REAL, PARAMETER :: XBETAI = (XLSTT / XRV) + (XGAMI * XTT)
+ REAL, PARAMETER :: XALPI = LOG(XESTT) + (XBETAI / XTT) + (XGAMI * LOG(XTT))
+!
+ REAL, PARAMETER :: XCONDI = 2.22 ! thermal conductivity of ice (W m-1 K-1)
+ REAL, PARAMETER :: XTH00 = 300. ! reference value for the potential
+ ! temperature
+ REAL, PARAMETER :: XRHOLI = 900. ! Volumic mass of liquid water
+!
+ INTEGER, PARAMETER :: NDAYSEC = 24 * 3600 ! Number of seconds in a day
+!
+!
+! Some machine precision value depending of real4/8 use
+!
+ REAL, PARAMETER :: XMNH_TINY = 1.0e-30 ! minimum real on this machine
+ REAL, PARAMETER :: XMNH_TINY_12 = SQRT(XMNH_TINY) ! sqrt(minimum real on this machine)
+ REAL, PARAMETER :: XMNH_EPSILON = EPSILON(XMNH_EPSILON) ! minimum space with 1.0
+ REAL, PARAMETER :: XMNH_HUGE = HUGE(XMNH_HUGE) ! minimum real on this machine
+
+ REAL, PARAMETER :: XEPS_DT = 1.0e-5 ! default value for DT test
+ REAL, PARAMETER :: XRES_FLAT_CART = 1.0e-12 ! default flat&cart residual tolerance
+ REAL, PARAMETER :: XRES_OTHER = 1.0e-9 ! default not flat&cart residual tolerance
+ REAL, PARAMETER :: XRES_PREP = 1.0e-8 ! default prep residual tolerance
+
+!
+ENDMODULE MODD_CST
+
+!! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+!! **************************************************************************************************
+!! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+!
+!
+!
+!
+!!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!!MNH_LIC for details. version 1.
+!!-----------------------------------------------------------------
+!!--------------- special set of characters for RCS information
+!!-----------------------------------------------------------------
+!! $Source$ $Revision$
+!! MASDEV4_7 init 2006/05/18 13:07:25
+!!-----------------------------------------------------------------
+!! ###################
+! MODULE MODI_INI_CST
+!! ###################
+!!
+!INTERFACE
+!!
+!subroutine INI_CST
+!END subroutine INI_CST
+!!
+!END INTERFACE
+!!
+!END MODULE MODI_INI_CST
+!!
+!!
+!!
+!! ##################
+! subroutine INI_CST
+!! ##################
+!!
+!!!**** *INI_CST * - routine to initialize the module MODD_CST
+!!!
+!!! PURPOSE
+!!! -------
+!! The purpose of this routine is to initialize the physical constants
+!! stored in module MODD_CST.
+!!
+!!
+!!!** METHOD
+!!! ------
+!!! The physical constants are set to their numerical values
+!!!
+!!!
+!!! EXTERNAL
+!!! --------
+!!! FMLOOK : to retrieve logical unit number associated to a file
+!!!
+!!! IMPLICIT ARGUMENTS
+!!! ------------------
+!!! Module MODD_CST : contains physical constants
+!!!
+!!! REFERENCE
+!!! ---------
+!!! Book2 of the documentation (module MODD_CST, routine INI_CST)
+!!!
+!!!
+!!! AUTHOR
+!!! ------
+!!! V. Ducrocq * Meteo France *
+!!!
+!!! MODIFICATIONS
+!!! -------------
+!!! Original 18/05/94
+!!! J. Stein 02/01/95 add the volumic mass of liquid water
+!!! J.-P. Pinty 13/12/95 add the water vapor pressure over solid ice
+!!! J. Stein 29/06/97 add XTH00
+!!! V. Masson 05/10/98 add XRHOLI
+!!! C. Mari 31/10/00 add NDAYSEC
+!!! V. Masson 01/03/03 add XCONDI
+!!! J. Escobar 28/03/2014 for pb with emissivity/aerosol reset XMNH_TINY=1.0e-80 in real8 case
+!!!
+!!-------------------------------------------------------------------------------
+!!
+!!* 0. DECLARATIONS
+!! ------------
+!!
+!USE MODD_CST
+!!
+!implicit none
+!!
+!!-------------------------------------------------------------------------------
+!!
+!!* 1. FUNDAMENTAL CONSTANTS
+!! ---------------------
+!!
+!!XPI = 2.*ASIN(1.)
+!!XKARMAN = 0.4
+!!XLIGHTSPEED = 299792458.
+!!XPLANCK = 6.6260755E-34
+!!XBOLTZ = 1.380658E-23
+!!XAVOGADRO = 6.0221367E+23
+!!
+!!-------------------------------------------------------------------------------
+!!
+!!* 2. ASTRONOMICAL CONSTANTS
+!! ----------------------
+!!
+!!XDAY = 86400.
+!!XSIYEA = 365.25*XDAY*2.*XPI/ 6.283076
+!!XSIDAY = XDAY/(1.+XDAY/XSIYEA)
+!!XOMEGA = 2.*XPI/XSIDAY
+!!NDAYSEC = 24*3600 ! Number of seconds in a day
+!!
+!!-------------------------------------------------------------------------------!
+!!
+!!
+!!* 3. TERRESTRIAL GEOIDE CONSTANTS
+!! ----------------------------
+!!
+!!XRADIUS = 6371229.
+!!XG = 9.80665
+!!
+!!-------------------------------------------------------------------------------
+!!
+!!* 4. REFERENCE PRESSURE
+!! -------------------
+!!
+!!XP00 = 1.E5
+!!XTH00 = 300.
+!!-------------------------------------------------------------------------------
+!!
+!!* 5. RADIATION CONSTANTS
+!! -------------------
+!!
+!!JUAN OVERFLOW XSTEFAN = 2.* XPI**5 * XBOLTZ**4 / (15.* XLIGHTSPEED**2 * XPLANCK**3)
+!!XSTEFAN = ( 2.* XPI**5 / 15. ) * ( (XBOLTZ / XPLANCK) * XBOLTZ ) * (XBOLTZ/(XLIGHTSPEED*XPLANCK))**2
+!!XI0 = 1370.
+!!
+!!-------------------------------------------------------------------------------
+!!
+!!* 6. THERMODYNAMIC CONSTANTS
+!! -----------------------
+!!
+!!XMD = 28.9644E-3
+!!XMV = 18.0153E-3
+!!XRD = XAVOGADRO * XBOLTZ / XMD
+!!XRV = XAVOGADRO * XBOLTZ / XMV
+!!XCPD = 7.* XRD /2.
+!!XCPV = 4.* XRV
+!!XRHOLW = 1000.
+!!XRHOLI = 900.
+!!XCONDI = 2.22
+!!XCL = 4.218E+3
+!!XCI = 2.106E+3
+!!XTT = 273.16
+!!XLVTT = 2.5008E+6
+!!XLSTT = 2.8345E+6
+!!XLMTT = XLSTT - XLVTT
+!!XESTT = 611.14
+!!XGAMW = (XCL - XCPV) / XRV
+!!XBETAW = (XLVTT/XRV) + (XGAMW * XTT)
+!!XALPW = LOG(XESTT) + (XBETAW /XTT) + (XGAMW *LOG(XTT))
+!!XGAMI = (XCI - XCPV) / XRV
+!!XBETAI = (XLSTT/XRV) + (XGAMI * XTT)
+!!XALPI = LOG(XESTT) + (XBETAI /XTT) + (XGAMI *LOG(XTT))
+!
+!!
+!! Some machine precision value depending of real4/8 use
+!!
+!
+!
+!!XMNH_EPSILON = EPSILON (XMNH_EPSILON )
+!!XMNH_HUGE = HUGE (XMNH_HUGE )
+!
+!!SeBi #ifdef MNH_MPI_DOUBLE_PRECISION
+!!XMNH_TINY = 1.0e-80
+!!XEPS_DT = 1.0e-5
+!!XRES_FLAT_CART = 1.0e-12
+!!XRES_OTHER = 1.0e-9
+!!XRES_PREP = 1.0e-8
+!!SeBi #else
+!!XMNH_TINY = TINY (XMNH_TINY )
+!!XEPS_DT = 1.0e-4
+!!XRES_FLAT_CART = 1.0e-12
+!!XRES_OTHER = 1.0e-7
+!!XRES_PREP = 1.0e-4
+!!SeBi #endif
+!!XMNH_TINY_12 = SQRT (XMNH_TINY )
+!
+!
+!
+!!
+!!-------------------------------------------------------------------------------
+!!
+!END subroutine INI_CST
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_SATMIXRATIO
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_SATMIXRATIO(KLON, &
+ PPRES, PT, PEW, PLV, PLS, PCPH)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON), INTENT(IN) :: PT ! temperature
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PEW ! vapor saturation mixing ratio
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLV ! latent heat L_v
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLS ! latent heat L_s
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCPH ! specific heat C_ph
+!
+ ENDsubroutine CONVECT_SATMIXRATIO
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_SATMIXRATIO
+! ######spl
+subroutine CONVECT_SATMIXRATIO(KLON, &
+ PPRES, PT, PEW, PLV, PLS, PCPH)
+! ################################################################
+!
+!!**** Compute vapor saturation mixing ratio over liquid water
+!!
+!!
+!! PDRPOSE
+!! -------
+!! The purpose of this routine is to determine saturation mixing ratio
+!! and to return values for L_v L_s and C_ph
+!!
+!!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XALPW, XBETAW, XGAMW ! constants for water saturation pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV ! specific heat for dry air and water vapor
+!! XCL, XCI ! specific heat for liquid water and ice
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporization, sublimation heat constant
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_SATMIXRATIO)
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!------------------------- ------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON), INTENT(IN) :: PT ! temperature
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PEW ! vapor saturation mixing ratio
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLV ! latent heat L_v
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLS ! latent heat L_s
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCPH ! specific heat C_ph
+!
+!* 0.2 Declarations of local variables :
+!
+ REAL, DIMENSION(KLON) :: ZT ! temperature
+ real :: ZEPS ! R_d / R_v
+!
+!
+!-------------------------------------------------------------------------------
+!
+ ZEPS = XRD / XRV
+!
+ ZT(:) = MIN(400., MAX(PT(:), 10.)) ! overflow bound
+ PEW(:) = EXP(XALPW - XBETAW / ZT(:) - XGAMW * ALOG(ZT(:)))
+ PEW(:) = ZEPS * PEW(:) / (PPRES(:) - PEW(:))
+!
+ PLV(:) = XLVTT + (XCPV - XCL) * (ZT(:) - XTT) ! compute L_v
+ PLS(:) = XLSTT + (XCPV - XCI) * (ZT(:) - XTT) ! compute L_i
+!
+ PCPH(:) = XCPD + XCPV * PEW(:) ! compute C_ph
+!
+ENDsubroutine CONVECT_SATMIXRATIO
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 modd 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ######spl
+MODULE MODD_CONVPAREXT
+! ######################
+!
+ implicit none
+!
+ INTEGER, SAVE :: JCVEXB ! start vertical computations at
+ ! 1 + JCVEXB = 1 + ( KBDIA - 1 )
+ INTEGER, SAVE :: JCVEXT ! limit vertical computations to
+ ! KLEV - JCVEXT = KLEV - ( KTDIA - 1 )
+!$OMP threadprivate(JCVEXB,JCVEXT)
+ENDMODULE MODD_CONVPAREXT
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 modd 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ######spl
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_TRIGGER_FUNCT
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_TRIGGER_FUNCT(KLON, KLEV, &
+ PPRES, PTH, PTHV, PTHES, &
+ PRV, PW, PZ, PDXDY, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, &
+ PTHVELCL, KLCL, KDPL, KPBL, OTRIG, &
+ PCAPE)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ INTEGER, INTENT(IN) :: KLEV ! vertical loop index
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH, PTHV ! theta, theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! envir. satur. theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! vapor mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of grid point (m)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PW ! vertical velocity
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PWLCL ! parcel velocity at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(OUT):: OTRIG ! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KPBL ! contains index of source layer top
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCAPE ! CAPE (J/kg) for diagnostics
+!
+ ENDsubroutine CONVECT_TRIGGER_FUNCT
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_TRIGGER_FUNCT
+! #########################################################################
+subroutine CONVECT_TRIGGER_FUNCT(KLON, KLEV, &
+ PPRES, PTH, PTHV, PTHES, &
+ PRV, PW, PZ, PDXDY, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, &
+ PTHVELCL, KLCL, KDPL, KPBL, OTRIG, &
+ PCAPE)
+! #########################################################################
+!
+!!**** Determine convective columns as well as the cloudy values of theta,
+!! and qv at the lifting condensation level (LCL)
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine convective columns
+!!
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!! What we look for is the undermost unstable level at each grid point.
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Routine CONVECT_SATMIXRATIO
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! Reference pressure
+!! XRD, XRV ! Gaz constants for dry air and water vapor
+!! XCPD ! Cpd (dry air)
+!! XTT ! triple point temperature
+!! XBETAW, XGAMW ! constants for vapor saturation pressure
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XZLCL ! maximum height difference between
+!! ! the surface and the DPL
+!! XZPBL ! minimum mixed layer depth to sustain convection
+!! XWTRIG ! constant in vertical velocity trigger
+!! XCDEPTH ! minimum necessary cloud depth
+!! XNHGAM ! coefficient for buoyancy term in w eq.
+!! ! accounting for nh-pressure
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of documentation ( routine TRIGGER_FUNCT)
+!! Fritsch and Chappell (1980), J. Atm. Sci., Vol. 37, 1722-1761.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 20/03/97 Select first departure level
+!! that produces a cloud thicker than XCDEPTH
+!! Last modified 12/12/97 add small perturbation
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR
+ USE MODD_CONVPAREXT
+ USE MODI_CONVECT_SATMIXRATIO
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ INTEGER, INTENT(IN) :: KLEV ! vertical loop index
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH, PTHV ! theta, theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! envir. satur. theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! vapor mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of grid point (m)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PW ! vertical velocity
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PWLCL ! parcel velocity at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(OUT):: OTRIG ! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KPBL ! contains index of source layer top
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCAPE ! CAPE (J/kg) for diagnostics
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: JKK, JK, JKP, JKM, JKDL, JL, JKT, JT! vertical loop index
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ real :: ZEPS, ZEPSA ! R_d / R_v, R_v / R_d
+ real :: ZCPORD, ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON) :: ZTHLCL, ZTLCL, ZRVLCL, & ! locals for PTHLCL,PTLCL
+ ZWLCL, ZZLCL, ZTHVELCL ! PRVLCL, ....
+ INTEGER, DIMENSION(KLON) :: IDPL, IPBL, ILCL ! locals for KDPL, ...
+ REAL, DIMENSION(KLON) :: ZPLCL ! pressure at LCL
+ REAL, DIMENSION(KLON) :: ZZDPL ! height of DPL
+ REAL, DIMENSION(KLON) :: ZTHVLCL ! theta_v at LCL = mixed layer value
+ REAL, DIMENSION(KLON) :: ZTMIX ! mixed layer temperature
+ REAL, DIMENSION(KLON) :: ZEVMIX ! mixed layer water vapor pressure
+ REAL, DIMENSION(KLON) :: ZDPTHMIX, ZPRESMIX ! mixed layer depth and pressure
+ REAL, DIMENSION(KLON) :: ZCAPE ! convective available energy (m^2/s^2/g)
+ REAL, DIMENSION(KLON) :: ZTHEUL ! updraft equiv. pot. temperature (K)
+ REAL, DIMENSION(KLON) :: ZLV, ZCPH! specific heats of vaporisation, dry air
+ REAL, DIMENSION(KLON) :: ZDP ! pressure between LCL and model layer
+ REAL, DIMENSION(KLON) :: ZTOP ! estimated cloud top (m)
+ REAL, DIMENSION(KLON, KLEV):: ZCAP ! CAPE at every level for diagnostics
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3 ! work arrays
+ LOGICAL, DIMENSION(KLON) :: GTRIG, GTRIG2 ! local arrays for OTRIG
+ LOGICAL, DIMENSION(KLON) :: GWORK1 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.3 Compute array bounds
+! --------------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Initialize local variables
+! --------------------------
+!
+ ZEPS = XRD / XRV
+ ZEPSA = XRV / XRD
+ ZCPORD = XCPD / XRD
+ ZRDOCP = XRD / XCPD
+ OTRIG(:) = .false.
+ IDPL(:) = KDPL(:)
+ IPBL(:) = KPBL(:)
+ ILCL(:) = KLCL(:)
+ PWLCL(:) = 0.
+ ZWLCL(:) = 0.
+ PTHLCL(:) = 1.
+ PTHVELCL(:) = 1.
+ PTLCL(:) = 1.
+ PRVLCL(:) = 0.
+ PWLCL(:) = 0.
+ PZLCL(:) = PZ(:, IKB)
+ ZZDPL(:) = PZ(:, IKB)
+ GTRIG2(:) = .true.
+ ZCAP(:, :) = 0.
+!
+!
+!
+! 1. Determine highest necessary loop test layer
+! -------------------------------------------
+!
+ JT = IKE - 2
+ do JK = IKB + 1, IKE - 2
+ if(PZ(1, JK) - PZ(1, IKB) < 12.E3) JT = JK
+ enddo
+!
+!
+!* 2. Enter loop for convection test
+! ------------------------------
+!
+ JKP = MINVAL(IDPL(:)) + 1
+ JKT = JT
+ do JKK = JKP, JKT
+!
+ GWORK1(:) = ZZDPL(:) - PZ(:, IKB) < XZLCL
+ ! we exit the trigger test when the center of the mixed layer is more
+ ! than 3500 m above soil level.
+ WHERE(GWORK1(:))
+ ZDPTHMIX(:) = 0.
+ ZPRESMIX(:) = 0.
+ ZTHLCL(:) = 0.
+ ZRVLCL(:) = 0.
+ ZZDPL(:) = PZ(:, JKK)
+ IDPL(:) = JKK
+ ENDWHERE
+!
+!
+!* 3. Construct a mixed layer of at least 60 hPa (XZPBL)
+! ------------------------------------------
+!
+ do JK = JKK, IKE - 1
+ JKM = JK + 1
+ do JI = 1, IIE
+ if(GWORK1(JI) .and. ZDPTHMIX(JI) < XZPBL) then
+ IPBL(JI) = JK
+ ZWORK1(JI) = PPRES(JI, JK) - PPRES(JI, JKM)
+ ZDPTHMIX(JI) = ZDPTHMIX(JI) + ZWORK1(JI)
+ ZPRESMIX(JI) = ZPRESMIX(JI) + PPRES(JI, JK) * ZWORK1(JI)
+ ZTHLCL(JI) = ZTHLCL(JI) + PTH(JI, JK) * ZWORK1(JI)
+ ZRVLCL(JI) = ZRVLCL(JI) + PRV(JI, JK) * ZWORK1(JI)
+ endif
+ enddo
+ if(MINVAL(ZDPTHMIX(:)) >= XZPBL) EXIT
+ enddo
+!
+!
+ WHERE(GWORK1(:))
+!
+ ZPRESMIX(:) = ZPRESMIX(:) / ZDPTHMIX(:)
+ ZTHLCL(:) = ZTHLCL(:) / ZDPTHMIX(:) + .3 ! add small perturbation
+ ZRVLCL(:) = ZRVLCL(:) / ZDPTHMIX(:) + 1.e-4
+ ZTHVLCL(:) = ZTHLCL(:) * (1.+ZEPSA * ZRVLCL(:)) &
+ / (1.+ZRVLCL(:))
+!
+!* 4.1 Use an empirical direct solution ( Bolton formula )
+! to determine temperature and pressure at LCL.
+! Nota: the adiabatic saturation temperature is not
+! equal to the dewpoint temperature
+! ----------------------------------------------------
+!
+!
+ ZTMIX(:) = ZTHLCL(:) * (ZPRESMIX(:) / XP00)**ZRDOCP
+ ZEVMIX(:) = ZRVLCL(:) * ZPRESMIX(:) / (ZRVLCL(:) + ZEPS)
+ ZEVMIX(:) = MAX(1.E-8, ZEVMIX(:))
+ ZWORK1(:) = LOG(ZEVMIX(:) / 613.3)
+ ! dewpoint temperature
+ ZWORK1(:) = (4780.8 - 32.19 * ZWORK1(:)) / (17.502 - ZWORK1(:))
+ ! adiabatic saturation temperature
+ ZTLCL(:) = ZWORK1(:) - (.212 + 1.571E-3 * (ZWORK1(:) - XTT) &
+ - 4.36E-4 * (ZTMIX(:) - XTT)) * (ZTMIX(:) - ZWORK1(:))
+ ZTLCL(:) = MIN(ZTLCL(:), ZTMIX(:))
+ ZPLCL(:) = XP00 * (ZTLCL(:) / ZTHLCL(:))**ZCPORD
+!
+ ENDWHERE
+!
+!
+!* 4.2 Correct ZTLCL in order to be completely consistent
+! with MNH saturation formula
+! ---------------------------------------------
+!
+ call CONVECT_SATMIXRATIO(KLON, ZPLCL, ZTLCL, ZWORK1, ZLV, ZWORK2, ZCPH)
+ WHERE(GWORK1(:))
+ ZWORK2(:) = ZWORK1(:) / ZTLCL(:) * (XBETAW / ZTLCL(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = (ZWORK1(:) - ZRVLCL(:)) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:))
+ ZTLCL(:) = ZTLCL(:) - ZLV(:) / ZCPH(:) * ZWORK2(:)
+!
+ ENDWHERE
+!
+!
+!* 4.3 If ZRVLCL = PRVMIX is oversaturated set humidity
+! and temperature to saturation values.
+! ---------------------------------------------
+!
+ call CONVECT_SATMIXRATIO(KLON, ZPRESMIX, ZTMIX, ZWORK1, ZLV, ZWORK2, ZCPH)
+ WHERE(GWORK1(:) .and. ZRVLCL(:) > ZWORK1(:))
+ ZWORK2(:) = ZWORK1(:) / ZTMIX(:) * (XBETAW / ZTMIX(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = (ZWORK1(:) - ZRVLCL(:)) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:))
+ ZTLCL(:) = ZTMIX(:) - ZLV(:) / ZCPH(:) * ZWORK2(:)
+ ZRVLCL(:) = ZRVLCL(:) - ZWORK2(:)
+ ZPLCL(:) = ZPRESMIX(:)
+ ZTHLCL(:) = ZTLCL(:) * (XP00 / ZPLCL(:))**ZRDOCP
+ ZTHVLCL(:) = ZTHLCL(:) * (1.+ZEPSA * ZRVLCL(:)) &
+ / (1.+ZRVLCL(:))
+ ENDWHERE
+!
+!
+!* 5.1 Determine vertical loop index at the LCL and DPL
+! --------------------------------------------------
+!
+ do JK = JKK, IKE - 1
+ do JI = 1, IIE
+ if(ZPLCL(JI) <= PPRES(JI, JK) .and. GWORK1(JI)) ILCL(JI) = JK + 1
+ enddo
+ enddo
+!
+!
+!* 5.2 Estimate height and environm. theta_v at LCL
+! --------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = ILCL(JI)
+ JKM = JK - 1
+ ZDP(JI) = LOG(ZPLCL(JI) / PPRES(JI, JKM)) / &
+ LOG(PPRES(JI, JK) / PPRES(JI, JKM))
+ ZWORK1(JI) = PTHV(JI, JKM) + (PTHV(JI, JK) - PTHV(JI, JKM)) * ZDP(JI)
+ ! we compute the precise value of the LCL
+ ! The precise height is between the levels ILCL and ILCL-1.
+ ZWORK2(JI) = PZ(JI, JKM) + (PZ(JI, JK) - PZ(JI, JKM)) * ZDP(JI)
+ enddo
+ WHERE(GWORK1(:))
+ ZTHVELCL(:) = ZWORK1(:)
+ ZZLCL(:) = ZWORK2(:)
+ ENDWHERE
+!
+!
+!* 6. Check to see if cloud is bouyant
+! --------------------------------
+!
+!* 6.1 Compute grid scale vertical velocity perturbation term ZWORK1
+! -------------------------------------------------------------
+!
+ ! normalize w grid scale to a 25 km refer. grid
+ do JI = 1, IIE
+ JK = ILCL(JI)
+ JKM = JK - 1
+ JKDL = IDPL(JI)
+ !ZWORK1(JI) = ( PW(JI,JKM) + ( PW(JI,JK) - PW(JI,JKM) ) * ZDP(JI) ) &
+ ZWORK1(JI) = (PW(JI, JK) + PW(JI, JKDL) * ZZLCL(JI) / PZ(JI, JKDL))*.5 &
+ * SQRT(PDXDY(JI) / XA25)
+! - 0.02 * ZZLCL(JI) / XZLCL ! avoid spurious convection
+ enddo
+ ! compute sign of normalized grid scale w
+ ZWORK2(:) = SIGN(1., ZWORK1(:))
+ ZWORK1(:) = XWTRIG * ZWORK2(:) * ABS(ZWORK1(:))**0.333 &
+ * (XP00 / ZPLCL(:))**ZRDOCP
+!
+!* 6.2 Compute parcel vertical velocity at LCL
+! ---------------------------------------
+!
+ do JI = 1, IIE
+ JKDL = IDPL(JI)
+ ZWORK3(JI) = XG * ZWORK1(JI) * (ZZLCL(JI) - PZ(JI, JKDL)) &
+ / (PTHV(JI, JKDL) + ZTHVELCL(JI))
+ enddo
+ WHERE(GWORK1(:))
+ ZWLCL(:) = 1.+.5 * ZWORK2(:) * SQRT(ABS(ZWORK3(:)))
+ GTRIG(:) = ZTHVLCL(:) - ZTHVELCL(:) + ZWORK1(:) > 0. .and. &
+ ZWLCL(:) > 0.
+ ENDWHERE
+!
+!
+!* 6.3 Look for parcel that produces sufficient cloud depth.
+! The cloud top is estimated as the level where the CAPE
+! is smaller than a given value (based on vertical velocity eq.)
+! --------------------------------------------------------------
+!
+ ZTHEUL(:) = ZTLCL(:) * (ZTHLCL(:) / ZTLCL(:)) &
+ **(1.-0.28 * ZRVLCL(:)) &
+ * EXP((3374.6525 / ZTLCL(:) - 2.5403) * &
+ ZRVLCL(:) * (1.+0.81 * ZRVLCL(:)))
+!
+ ZCAPE(:) = 0.
+ ZTOP(:) = 0.
+ ZWORK3(:) = 0.
+ JKM = MINVAL(ILCL(:))
+ do JL = JKM, JT
+ JK = JL + 1
+ do JI = 1, IIE
+ ZWORK1(JI) = (2.*ZTHEUL(JI) / &
+ (PTHES(JI, JK) + PTHES(JI, JL)) - 1.) * (PZ(JI, JK) - PZ(JI, JL))
+ if(JL < ILCL(JI)) ZWORK1(JI) = 0.
+ ! if ( JL <= ILCL(JI) ) ZWORK1(JI) = 0.
+ ZCAPE(JI) = ZCAPE(JI) + ZWORK1(JI)
+ ZCAP(JI, JKK) = ZCAP(JI, JKK) + XG * MAX(0., ZWORK1(JI)) ! actual CAPE
+ ZWORK2(JI) = XNHGAM * XG * ZCAPE(JI) + 1.05 * ZWLCL(JI) * ZWLCL(JI)
+ ! the factor 1.05 takes entrainment into account
+ ZWORK2(JI) = SIGN(1., ZWORK2(JI))
+ ZWORK3(JI) = ZWORK3(JI) + MIN(0., ZWORK2(JI))
+ ZWORK3(JI) = MAX(-1., ZWORK3(JI))
+ ! Nota, the factors ZWORK2 and ZWORK3 are only used to avoid
+ ! if and goto statements, the difficulty is to extract only
+ ! the level where the criterium is first fullfilled
+ ZTOP(JI) = PZ(JI, JL)*.5 * (1.+ZWORK2(JI)) * (1.+ZWORK3(JI)) + &
+ ZTOP(JI)*.5 * (1.-ZWORK2(JI))
+ enddo
+ enddo
+!
+!
+ WHERE(ZTOP(:) - ZZLCL(:) >= XCDEPTH .and. GTRIG(:) .and. GTRIG2(:))
+ GTRIG2(:) = .false.
+ OTRIG(:) = GTRIG(:) ! we select the first departure level
+ PTHLCL(:) = ZTHLCL(:) ! that gives sufficient cloud depth
+ PRVLCL(:) = ZRVLCL(:)
+ PTLCL(:) = ZTLCL(:)
+ PWLCL(:) = ZWLCL(:)
+ PZLCL(:) = ZZLCL(:)
+ PTHVELCL(:) = ZTHVELCL(:)
+ KDPL(:) = IDPL(:)
+ KPBL(:) = IPBL(:)
+ KLCL(:) = ILCL(:)
+ ENDWHERE
+!
+ enddo
+!
+ do JI = 1, IIE
+ PCAPE(JI) = MAXVAL(ZCAP(JI, :)) ! maximum CAPE for diagnostics
+ enddo
+!
+!
+ENDsubroutine CONVECT_TRIGGER_FUNCT
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #############################################################################
+! #################
+MODULE MODI_CONVECT_CONDENS
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_CONDENS(KLON, &
+ KICE, PPRES, PTHL, PRW, PRCO, PRIO, PZ, OWORK1, &
+ PT, PEW, PRC, PRI, PLV, PLS, PCPH)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHL ! enthalpy (J/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRW ! total water mixing ratio
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRCO ! cloud water estimate (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRIO ! cloud ice estimate (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PZ ! level height (m)
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OWORK1 ! logical mask
+!
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PT ! temperature
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRC ! cloud water mixing ratio(kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRI ! cloud ice mixing ratio (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLV ! latent heat L_v
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLS ! latent heat L_s
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCPH ! specific heat C_ph
+ REAL, DIMENSION(KLON), INTENT(OUT):: PEW ! water saturation mixing ratio
+!
+ ENDsubroutine CONVECT_CONDENS
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_CONDENS
+subroutine CONVECT_CONDENS(KLON, &
+ KICE, PPRES, PTHL, PRW, PRCO, PRIO, PZ, OWORK1, &
+ PT, PEW, PRC, PRI, PLV, PLS, PCPH)
+! #############################################################################
+!
+!!**** Compute temperature cloud and ice water content from enthalpy and r_w
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine cloud condensate
+!! and to return values for L_v, L_s and C_ph
+!!
+!!
+!!** METHOD
+!! ------
+!! Condensate is extracted iteratively
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XALPW, XBETAW, XGAMW ! constants for water saturation pressure
+!! XALPI, XBETAI, XGAMI ! constants for ice saturation pressure
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV ! specific heat for dry air and water vapor
+!! XCL, XCI ! specific heat for liquid water and ice
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporization, sublimation heat constant
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONVPAR
+!! XTFRZ1 ! begin of freezing interval
+!! XTFRZ2 ! end of freezing interval
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_CONDENS)
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHL ! enthalpy (J/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRW ! total water mixing ratio
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRCO ! cloud water estimate (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRIO ! cloud ice estimate (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PZ ! level height (m)
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OWORK1 ! logical mask
+!
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PT ! temperature
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRC ! cloud water mixing ratio(kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRI ! cloud ice mixing ratio (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLV ! latent heat L_v
+ REAL, DIMENSION(KLON), INTENT(OUT):: PLS ! latent heat L_s
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCPH ! specific heat C_ph
+ REAL, DIMENSION(KLON), INTENT(OUT):: PEW ! water saturation mixing ratio
+!
+!* 0.2 Declarations of local variables KLON
+!
+ INTEGER :: JITER ! iteration index
+ real :: ZEPS ! R_d / R_v
+!
+ REAL, DIMENSION(KLON) :: ZEI ! ice saturation mixing ratio
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, ZT ! work arrays
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Initialize temperature and Exner function
+! -----------------------------------------
+!
+ ZEPS = XRD / XRV
+!
+!
+ ! Make a first temperature estimate, based e.g. on values of
+ ! r_c and r_i at lower level
+!
+ !! Note that the definition of ZCPH is not the same as used in
+ !! routine CONVECT_SATMIXRATIO
+ PCPH(:) = XCPD + XCPV * PRW(:)
+ ZWORK1(:) = (1.+PRW(:)) * XG * PZ(:)
+ PT(:) = (PTHL(:) + PRCO(:) * XLVTT + PRIO(:) * XLSTT - ZWORK1(:)) &
+ / PCPH(:)
+ PT(:) = MAX(180., MIN(330., PT(:))) ! set overflow bounds in
+ ! case that PTHL=0
+!
+!
+!* 2. Enter the iteration loop
+! ------------------------
+!
+ do JITER = 1, 6
+ PEW(:) = EXP(XALPW - XBETAW / PT(:) - XGAMW * ALOG(PT(:)))
+ ZEI(:) = EXP(XALPI - XBETAI / PT(:) - XGAMI * ALOG(PT(:)))
+ PEW(:) = ZEPS * PEW(:) / (PPRES(:) - PEW(:))
+ ZEI(:) = ZEPS * ZEI(:) / (PPRES(:) - ZEI(:))
+!
+ PLV(:) = XLVTT + (XCPV - XCL) * (PT(:) - XTT) ! compute L_v
+ PLS(:) = XLSTT + (XCPV - XCI) * (PT(:) - XTT) ! compute L_i
+!
+ ZWORK2(:) = (XTFRZ1 - PT(:)) / (XTFRZ1 - XTFRZ2) ! freezing interval
+ ZWORK2(:) = MAX(0., MIN(1., ZWORK2(:))) * REAL(KICE)
+ ZWORK3(:) = (1.-ZWORK2(:)) * PEW(:) + ZWORK2(:) * ZEI(:)
+ PRC(:) = MAX(0.,(1.-ZWORK2(:)) * (PRW(:) - ZWORK3(:)))
+ PRI(:) = MAX(0., ZWORK2(:) * (PRW(:) - ZWORK3(:)))
+ ZT(:) = (PTHL(:) + PRC(:) * PLV(:) + PRI(:) * PLS(:) - ZWORK1(:)) &
+ / PCPH(:)
+ PT(:) = PT(:) + (ZT(:) - PT(:)) * 0.4 ! force convergence
+ PT(:) = MAX(175., MIN(330., PT(:)))
+ enddo
+!
+!
+ENDsubroutine CONVECT_CONDENS
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_MIXING_FUNCT
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_MIXING_FUNCT(KLON, &
+ PMIXC, KMF, PER, PDR)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KMF ! switch for dist. function
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMIXC ! critical mixed fraction
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PER ! normalized entrainment rate
+ REAL, DIMENSION(KLON), INTENT(OUT):: PDR ! normalized detrainment rate
+!
+ ENDsubroutine CONVECT_MIXING_FUNCT
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_MIXING_FUNCT
+! ######spl
+subroutine CONVECT_MIXING_FUNCT(KLON, &
+ PMIXC, KMF, PER, PDR)
+! #######################################################
+!
+!!**** Determine the area under the distribution function
+!! KMF = 1 : gaussian KMF = 2 : triangular distribution function
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the entrainment and
+!! detrainment rate by evaluating the are under the distribution
+!! function. The integration interval is limited by the critical
+!! mixed fraction PMIXC
+!!
+!!
+!!
+!!** METHOD
+!! ------
+!! Use handbook of mathemat. functions by Abramowitz and Stegun, 1968
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of documentation ( routine MIXING_FUNCT)
+!! Abramovitz and Stegun (1968), handbook of math. functions
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KMF ! switch for dist. function
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMIXC ! critical mixed fraction
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PER ! normalized entrainment rate
+ REAL, DIMENSION(KLON), INTENT(OUT):: PDR ! normalized detrainment rate
+!
+!* 0.2 Declarations of local variables :
+!
+ real :: ZSIGMA = 0.166666667 ! standard deviation
+ real :: ZFE = 4.931813949 ! integral normalization
+ real :: ZSQRTP = 2.506628, ZP = 0.33267 ! constants
+ real :: ZA1 = 0.4361836, ZA2 = -0.1201676 ! constants
+ real :: ZA3 = 0.9372980, ZT1 = 0.500498 ! constants
+ real :: ZE45 = 0.01111 ! constant
+!
+ REAL, DIMENSION(KLON) :: ZX, ZY, ZW1, ZW2 ! work variables
+ real :: ZW11
+!
+!
+!-------------------------------------------------------------------------------
+!
+! 1. Use gaussian function for KMF=1
+! -------------------------------
+!
+ if(KMF == 1) then
+ ! ZX(:) = ( PMIXC(:) - 0.5 ) / ZSIGMA
+ ZX(:) = 6.*PMIXC(:) - 3.
+ ZW1(:) = 1./(1.+ZP * ABS(ZX(:)))
+ ZY(:) = EXP(-0.5 * ZX(:) * ZX(:))
+ ZW2(:) = ZA1 * ZW1(:) + ZA2 * ZW1(:) * ZW1(:) + &
+ ZA3 * ZW1(:) * ZW1(:) * ZW1(:)
+ ZW11 = ZA1 * ZT1 + ZA2 * ZT1 * ZT1 + ZA3 * ZT1 * ZT1 * ZT1
+ endif
+!
+ WHERE(KMF == 1 .and. ZX(:) >= 0.)
+ PER(:) = ZSIGMA * (0.5 * (ZSQRTP - ZE45 * ZW11 &
+ - ZY(:) * ZW2(:)) + ZSIGMA * (ZE45 - ZY(:))) &
+ - 0.5 * ZE45 * PMIXC(:) * PMIXC(:)
+ PDR(:) = ZSIGMA * (0.5 * (ZY(:) * ZW2(:) - ZE45 * ZW11) &
+ + ZSIGMA * (ZE45 - ZY(:))) &
+ - ZE45 * (0.5 + 0.5 * PMIXC(:) * PMIXC(:) - PMIXC(:))
+ ENDWHERE
+ WHERE(KMF == 1 .and. ZX(:) < 0.)
+ PER(:) = ZSIGMA * (0.5 * (ZY(:) * ZW2(:) - ZE45 * ZW11) &
+ + ZSIGMA * (ZE45 - ZY(:))) &
+ - 0.5 * ZE45 * PMIXC(:) * PMIXC(:)
+ PDR(:) = ZSIGMA * (0.5 * (ZSQRTP - ZE45 * ZW11 - ZY(:) &
+ * ZW2(:)) + ZSIGMA * (ZE45 - ZY(:))) &
+ - ZE45 * (0.5 + 0.5 * PMIXC(:) * PMIXC(:) - PMIXC(:))
+ ENDWHERE
+!
+ PER(:) = PER(:) * ZFE
+ PDR(:) = PDR(:) * ZFE
+!
+!
+! 2. Use triangular function KMF=2
+! -------------------------------
+!
+! not yet released
+!
+!
+ENDsubroutine CONVECT_MIXING_FUNCT
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_UPDRAFT
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_UPDRAFT(KLON, KLEV, &
+ KICE, PPRES, PDPRES, PZ, PTHL, PTHV, PTHES, PRW, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, PTHVELCL, &
+ PMFLCL, OTRIG, KLCL, KDPL, KPBL, &
+ PUMF, PUER, PUDR, PUTHL, PUTHV, PURW, &
+ PURC, PURI, PURR, PURS, PUPR, &
+ PUTPR, PCAPE, KCTL, KETL, PUTT)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHV ! grid scale theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! grid scale saturated theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PWLCL ! parcel velocity at LCL (m/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMFLCL ! cloud base unit mass flux
+ ! (kg/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(INOUT):: OTRIG! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! " vert. index of source layertop
+!
+!
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KETL ! contains vert. index of &
+ !equilibrium (zero buoyancy) level
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHV ! updraft theta_v (K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTT ! updraft temperature(K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURI ! updraft cloud ice (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURR ! liquid precipit. (kg/kg)
+ ! produced in model layer
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT)::PURS ! solid precipit. (kg/kg)
+ ! produced in model layer
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT)::PUPR ! updraft precipitation in
+ ! flux units (kg water / s)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PUTPR ! total updraft precipitation
+ ! in flux units (kg water / s)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCAPE ! available potent. energy
+!
+ ENDsubroutine CONVECT_UPDRAFT
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_UPDRAFT
+! ##########################################################################
+subroutine CONVECT_UPDRAFT(KLON, KLEV, &
+ KICE, PPRES, PDPRES, PZ, PTHL, PTHV, PTHES, PRW, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, PTHVELCL, &
+ PMFLCL, OTRIG, KLCL, KDPL, KPBL, &
+ PUMF, PUER, PUDR, PUTHL, PUTHV, PURW, &
+ PURC, PURI, PURR, PURS, PUPR, &
+ PUTPR, PCAPE, KCTL, KETL, PUTT)
+! ##########################################################################
+!
+!!**** Compute updraft properties from DPL to CTL.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine updraft properties
+!! ( mass flux, thermodynamics, precipitation )
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Routine CONVECT_MIXING_FUNCT
+!! Routine CONVECT_CONDENS
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV, XCL ! Cp of dry air, water vapor and liquid water
+!! XTT ! triple point temperature
+!! XLVTT ! vaporisation heat at XTT
+!!
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XCRAD ! cloud radius
+!! XCDEPTH ! minimum necessary cloud depth
+!! XENTR ! entrainment constant
+!! XRCONV ! constant in precipitation conversion
+!! XNHGAM ! coefficient for buoyancy term in w eq.
+!! ! accounting for nh-pressure
+!! XTFRZ1 ! begin of freezing interval
+!! XTFRZ2 ! begin of freezing interval
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_UPDRAFT)
+!! Kain and Fritsch, 1990, J. Atmos. Sci., Vol.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 10/12/97
+!! V.Masson, C.Lac, Sept. 2010 : Correction of a loop for reproducibility
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR
+ USE MODD_CONVPAREXT
+!
+ USE MODI_CONVECT_CONDENS
+ USE MODI_CONVECT_MIXING_FUNCT
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHV ! grid scale theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! grid scale saturated theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PWLCL ! parcel velocity at LCL (m/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMFLCL ! cloud base unit mass flux
+ ! (kg/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(INOUT):: OTRIG! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! " vert. index of source layertop
+!
+!
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KETL ! contains vert. index of &
+ !equilibrium (zero buoyancy) level
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHV ! updraft theta_v (K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTT ! updraft temperature(K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURI ! updraft cloud ice (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURR ! liquid precipit. (kg/kg)
+ ! produced in model layer
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT)::PURS ! solid precipit. (kg/kg)
+ ! produced in model layer
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT)::PUPR ! updraft precipitation in
+ ! flux units (kg water / s)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PUTPR ! total updraft precipitation
+ ! in flux units (kg water / s)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCAPE ! available potent. energy
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal and vertical loop bounds
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: JK, JKP, JKM, JK1, JK2, JKMIN ! vertical loop index
+ real :: ZEPSA ! R_v / R_d, C_pv / C_pd
+ real :: ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON) :: ZUT ! updraft temperature (K)
+ REAL, DIMENSION(KLON) :: ZUW1, ZUW2 ! square of updraft vert.
+ ! velocity at levels k and k+1
+ REAL, DIMENSION(KLON) :: ZE1, ZE2, ZD1, ZD2 ! fractional entrainm./detrain
+ ! rates at levels k and k+1
+ REAL, DIMENSION(KLON) :: ZMIXF ! critical mixed fraction
+ REAL, DIMENSION(KLON) :: ZCPH ! specific heat C_ph
+ REAL, DIMENSION(KLON) :: ZLV, ZLS ! latent heat of vaporis., sublim.
+ REAL, DIMENSION(KLON) :: ZURV ! updraft water vapor at level k+1
+ REAL, DIMENSION(KLON) :: ZPI ! Pi=(P0/P)**(Rd/Cpd)
+ REAL, DIMENSION(KLON) :: ZTHEUL ! theta_e for undilute ascent
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, ZWORK4, ZWORK5, &
+ ZWORK6 ! work arrays
+ INTEGER, DIMENSION(KLON) :: IWORK ! wok array
+ LOGICAL, DIMENSION(KLON) :: GWORK1, GWORK2, GWORK4
+ ! work arrays
+ LOGICAL, DIMENSION(KLON, KLEV) :: GWORK6 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+! 0.3 Set loop bounds
+! ---------------
+!
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+ IIE = KLON
+!
+!
+!* 1. Initialize updraft properties and local variables
+! -------------------------------------------------
+!
+ ZEPSA = XRV / XRD
+ ZRDOCP = XRD / XCPD
+!
+ PUMF(:, :) = 0.
+ PUER(:, :) = 0.
+ PUDR(:, :) = 0.
+ PUTHL(:, :) = 0.
+ PUTHV(:, :) = 0.
+ PUTT(:, :) = 0.
+ PURW(:, :) = 0.
+ PURC(:, :) = 0.
+ PURI(:, :) = 0.
+ PUPR(:, :) = 0.
+ PURR(:, :) = 0.
+ PURS(:, :) = 0.
+ PUTPR(:) = 0.
+ ZUW1(:) = PWLCL(:) * PWLCL(:)
+ ZUW2(:) = 0.
+ ZE1(:) = 1.
+ ZD1(:) = 0.
+ PCAPE(:) = 0.
+ KCTL(:) = IKB
+ KETL(:) = KLCL(:)
+ GWORK2(:) = .true.
+ ZPI(:) = 1.
+ ZWORK3(:) = 0.
+ ZWORK4(:) = 0.
+ ZWORK5(:) = 0.
+ ZWORK6(:) = 0.
+ GWORK1(:) = .false.
+ GWORK4(:) = .false.
+!
+!
+!* 1.1 Compute undilute updraft theta_e for CAPE computations
+! Bolton (1980) formula.
+! Define accurate enthalpy for updraft
+! -----------------------------------------------------
+!
+ ZTHEUL(:) = PTLCL(:) * (PTHLCL(:) / PTLCL(:))**(1.-0.28 * PRVLCL(:)) &
+ * EXP((3374.6525 / PTLCL(:) - 2.5403) * &
+ PRVLCL(:) * (1.+0.81 * PRVLCL(:)))
+!
+!
+ ZWORK1(:) = (XCPD + PRVLCL(:) * XCPV) * PTLCL(:) &
+ + (1.+PRVLCL(:)) * XG * PZLCL(:)
+!
+!
+!* 2. Set updraft properties between DPL and LCL
+! ------------------------------------------
+!
+ JKP = MAXVAL(KLCL(:))
+ JKM = MINVAL(KDPL(:))
+ do JK = JKM, JKP
+ do JI = 1, IIE
+ if(JK >= KDPL(JI) .and. JK < KLCL(JI)) then
+ PUMF(JI, JK) = PMFLCL(JI)
+ PUTHL(JI, JK) = ZWORK1(JI)
+ PUTHV(JI, JK) = PTHLCL(JI) * (1.+ZEPSA * PRVLCL(JI)) / &
+ (1.+PRVLCL(JI))
+ PURW(JI, JK) = PRVLCL(JI)
+ endif
+ enddo
+ enddo
+!
+!
+!* 3. Enter loop for updraft computations
+! ------------------------------------
+!
+! Correction for reproduciblity
+!JKMIN = MINVAL( KLCL(:) ) - 1
+ JKMIN = MINVAL(KLCL(:)) - 2
+ do JK = MAX(IKB + 1, JKMIN), IKE - 1
+ ZWORK6(:) = 1.
+ JKP = JK + 1
+!
+ GWORK4(:) = JK >= KLCL(:) - 1
+ GWORK1(:) = GWORK4(:) .and. GWORK2(:) ! this mask is used to confine
+ ! updraft computations between the LCL and the CTL
+!
+ WHERE(JK == KLCL(:) - 1) ZWORK6(:) = 0. ! factor that is used in buoyancy
+ ! computation at first level above LCL
+!
+!
+!* 4. Estimate condensate, L_v L_i, Cph and theta_v at level k+1
+! ----------------------------------------------------------
+!
+ ZWORK1(:) = PURC(:, JK) + PURR(:, JK)
+ ZWORK2(:) = PURI(:, JK) + PURS(:, JK)
+ call CONVECT_CONDENS(KLON, KICE, PPRES(:, JKP), PUTHL(:, JK), PURW(:, JK), &
+ ZWORK1, ZWORK2, PZ(:, JKP), GWORK1, ZUT, ZURV, &
+ PURC(:, JKP), PURI(:, JKP), ZLV, ZLS, ZCPH)
+!
+!
+ ZPI(:) = (XP00 / PPRES(:, JKP))**ZRDOCP
+ WHERE(GWORK1(:))
+!
+ PUTHV(:, JKP) = ZPI(:) * ZUT(:) * (1.+ZEPSA * ZURV(:)) &
+ / (1.+PURW(:, JK))
+ PUTT(:, JKP) = ZUT(:)
+!
+!
+!* 5. Compute square of vertical velocity using entrainment
+! at level k
+! -----------------------------------------------------
+!
+ ZWORK3(:) = PZ(:, JKP) - PZ(:, JK) * ZWORK6(:) - &
+ (1.-ZWORK6(:)) * PZLCL(:) ! level thickness
+ ZWORK4(:) = PTHV(:, JK) * ZWORK6(:) + &
+ (1.-ZWORK6(:)) * PTHVELCL(:)
+ ZWORK5(:) = 2.*ZUW1(:) * PUER(:, JK) / MAX(.1, PUMF(:, JK))
+ ZUW2(:) = ZUW1(:) + ZWORK3(:) * XNHGAM * XG * &
+ ((PUTHV(:, JK) + PUTHV(:, JKP)) / &
+ (ZWORK4(:) + PTHV(:, JKP)) - 1.) & ! buoyancy term
+ - ZWORK5(:) ! entrainment term
+!
+!
+!* 6. Update total precipitation: dr_r=(r_c+r_i)*exp(-rate*dz)
+! --------------------------------------------------------
+!
+! compute level mean vertical velocity
+ ZWORK2(:) = 0.5 * &
+ (SQRT(MAX(1.E-2, ZUW2(:))) + &
+ SQRT(MAX(1.E-2, ZUW1(:))))
+ PURR(:, JKP) = 0.5 * (PURC(:, JK) + PURC(:, JKP) + PURI(:, JK) + PURI(:, JKP)) &
+ * (1.-EXP(-XRCONV * ZWORK3(:) / ZWORK2(:)))
+ PUPR(:, JKP) = PURR(:, JKP) * PUMF(:, JK) ! precipitation rate ( kg water / s)
+ PUTPR(:) = PUTPR(:) + PUPR(:, JKP) ! total precipitation rate
+ ZWORK2(:) = PURR(:, JKP) / MAX(1.E-8, PURC(:, JKP) + PURI(:, JKP))
+ PURR(:, JKP) = ZWORK2(:) * PURC(:, JKP) ! liquid precipitation
+ PURS(:, JKP) = ZWORK2(:) * PURI(:, JKP) ! solid precipitation
+!
+!
+!* 7. Update r_c, r_i, enthalpy, r_w for precipitation
+! -------------------------------------------------------
+!
+ PURW(:, JKP) = PURW(:, JK) - PURR(:, JKP) - PURS(:, JKP)
+ PURC(:, JKP) = PURC(:, JKP) - PURR(:, JKP)
+ PURI(:, JKP) = PURI(:, JKP) - PURS(:, JKP)
+ PUTHL(:, JKP) = (XCPD + PURW(:, JKP) * XCPV) * ZUT(:) &
+ + (1.+PURW(:, JKP)) * XG * PZ(:, JKP) &
+ - ZLV(:) * PURC(:, JKP) - ZLS(:) * PURI(:, JKP)
+!
+ ZUW1(:) = ZUW2(:)
+!
+ ENDWHERE
+!
+!
+!* 8. Compute entrainment and detrainment using conservative
+! variables adjusted for precipitation ( not for entrainment)
+! -----------------------------------------------------------
+!
+!* 8.1 Compute critical mixed fraction by estimating unknown
+! T^mix r_c^mix and r_i^mix from enthalpy^mix and r_w^mix
+! We determine the zero crossing of the linear curve
+! evaluating the derivative using ZMIXF=0.1.
+! -----------------------------------------------------
+!
+ ZMIXF(:) = 0.1 ! starting value for critical mixed fraction
+ ZWORK1(:) = ZMIXF(:) * PTHL(:, JKP) &
+ + (1.-ZMIXF(:)) * PUTHL(:, JKP) ! mixed enthalpy
+ ZWORK2(:) = ZMIXF(:) * PRW(:, JKP) &
+ + (1.-ZMIXF(:)) * PURW(:, JKP) ! mixed r_w
+!
+ call CONVECT_CONDENS(KLON, KICE, PPRES(:, JKP), ZWORK1, ZWORK2, &
+ PURC(:, JKP), PURI(:, JKP), PZ(:, JKP), GWORK1, ZUT, &
+ ZWORK3, ZWORK4, ZWORK5, ZLV, ZLS, ZCPH)
+! put in enthalpy and r_w and get T r_c, r_i (ZUT, ZWORK4-5)
+!
+ ! compute theta_v of mixture
+ ZWORK3(:) = ZUT(:) * ZPI(:) * (1.+ZEPSA * ( &
+ ZWORK2(:) - ZWORK4(:) - ZWORK5(:))) / (1.+ZWORK2(:))
+ ! compute final value of critical mixed fraction using theta_v
+ ! of mixture, grid-scale and updraft
+ ZMIXF(:) = MAX(0., PUTHV(:, JKP) - PTHV(:, JKP)) * ZMIXF(:) / &
+ (PUTHV(:, JKP) - ZWORK3(:) + 1.E-10)
+ ZMIXF(:) = MAX(0., MIN(1., ZMIXF(:)))
+!
+!
+!* 8.2 Compute final midlevel values for entr. and detrainment
+! after call of distribution function
+! -------------------------------------------------------
+!
+!
+ call CONVECT_MIXING_FUNCT(KLON, ZMIXF, 1, ZE2, ZD2)
+! Note: routine MIXING_FUNCT returns fractional entrainm/detrainm. rates
+!
+! ZWORK1(:) = XENTR * PMFLCL(:) * PDPRES(:,JKP) / XCRAD ! rate of env. inflow
+!*MOD
+ zwork1(:) = xentr * xg / xcrad * pumf(:, jk) * (pz(:, jkp) - pz(:, jk))
+! ZWORK1(:) = XENTR * pumf(:,jk) * PDPRES(:,JKP) / XCRAD ! rate of env. inflow
+!*MOD
+ ZWORK2(:) = 0.
+ WHERE(GWORK1(:)) ZWORK2(:) = 1.
+ ZE2(:) = .5; ZD2(:) = .6 ! set entrainment=detrainment for better
+ ! mass flux profiles in deep continental convection
+ WHERE(PUTHV(:, JKP) > PTHV(:, JKP))
+ PUER(:, JKP) = 0.5 * ZWORK1(:) * (ZE1(:) + ZE2(:)) * ZWORK2(:)
+ PUDR(:, JKP) = 0.5 * ZWORK1(:) * (ZD1(:) + ZD2(:)) * ZWORK2(:)
+ elseWHERE
+ PUER(:, JKP) = 0.
+ PUDR(:, JKP) = ZWORK1(:) * ZWORK2(:)
+ ENDWHERE
+!
+!* 8.3 Determine equilibrium temperature level
+! --------------------------------------
+!
+ WHERE(PUTHV(:, JKP) > PTHV(:, JKP) .and. JK > KLCL(:) + 1 &
+ .and. GWORK1(:))
+ KETL(:) = JKP ! equilibrium temperature level
+ ENDWHERE
+!
+!* 8.4 If the calculated detrained mass flux is greater than
+! the total updraft mass flux, or vertical velocity is
+! negative, all cloud mass detrains at previous model level,
+! exit updraft calculations - CTL is attained
+! -------------------------------------------------------
+!
+ WHERE(GWORK1(:)) &
+ GWORK2(:) = PUMF(:, JK) - PUDR(:, JKP) > 10. .and. ZUW2(:) > 0.
+ WHERE(GWORK2(:)) KCTL(:) = JKP ! cloud top level
+!!!! Correction Bug C.Lac 30/10/08 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ KCTL(:) = MIN(KCTL(:), IKE - 1)
+ GWORK1(:) = GWORK2(:) .and. GWORK4(:)
+!
+ if(COUNT(GWORK2(:)) == 0) EXIT
+!
+!
+!* 9. Compute CAPE for undilute ascent using theta_e and
+! theta_es instead of theta_v. This estimation produces
+! a significantly larger value for CAPE than the actual one.
+! ----------------------------------------------------------
+!
+ WHERE(GWORK1(:))
+!
+ ZWORK3(:) = PZ(:, JKP) - PZ(:, JK) * ZWORK6(:) - &
+ (1.-ZWORK6(:)) * PZLCL(:) ! level thickness
+ ZWORK2(:) = PTHES(:, JK) + (1.-ZWORK6(:)) * &
+ (PTHES(:, JKP) - PTHES(:, JK)) / (PZ(:, JKP) - PZ(:, JK)) * &
+ (PZLCL(:) - PZ(:, JK)) ! linear interpolation for theta_es at LCL
+ ! ( this is only done for model level just above LCL
+!
+ ZWORK1(:) = (2.*ZTHEUL(:)) / (ZWORK2(:) + PTHES(:, JKP)) - 1.
+ PCAPE(:) = PCAPE(:) + XG * ZWORK3(:) * MAX(0., ZWORK1(:))
+!
+!
+!* 10. Compute final values of updraft mass flux, enthalpy, r_w
+! at level k+1
+! --------------------------------------------------------
+!
+ PUMF(:, JKP) = PUMF(:, JK) - PUDR(:, JKP) + PUER(:, JKP)
+ PUMF(:, JKP) = MAX(PUMF(:, JKP), 0.1)
+ PUTHL(:, JKP) = (PUMF(:, JK) * PUTHL(:, JK) + &
+ PUER(:, JKP) * PTHL(:, JK) - PUDR(:, JKP) * PUTHL(:, JK)) &
+ / PUMF(:, JKP) + PUTHL(:, JKP) - PUTHL(:, JK)
+ PURW(:, JKP) = (PUMF(:, JK) * PURW(:, JK) + &
+ PUER(:, JKP) * PRW(:, JK) - PUDR(:, JKP) * PURW(:, JK)) &
+ / PUMF(:, JKP) - PURR(:, JKP) - PURS(:, JKP)
+!
+!
+ ZE1(:) = ZE2(:) ! update fractional entrainment/detrainment
+ ZD1(:) = ZD2(:)
+!
+ ENDWHERE
+!
+ enddo
+!
+!* 12.1 Set OTRIG to False if cloud thickness < XCDEPTH
+! or CAPE < 1
+! ------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KCTL(JI)
+ OTRIG(JI) = PZ(JI, JK) - PZLCL(JI) >= XCDEPTH &
+ .and. PCAPE(JI) > 1.
+ enddo
+ WHERE(.not. OTRIG(:))
+ KCTL(:) = IKB
+ ENDWHERE
+ KETL(:) = MAX(KETL(:), KLCL(:) + 2)
+ KETL(:) = MIN(KETL(:), KCTL(:))
+!
+!
+!* 12.2 If the ETL and CTL are the same detrain updraft mass
+! flux at this level
+! -------------------------------------------------------
+!
+ ZWORK1(:) = 0.
+ WHERE(KETL(:) == KCTL(:)) ZWORK1(:) = 1.
+!
+ do JI = 1, IIE
+ JK = KETL(JI)
+ PUDR(JI, JK) = PUDR(JI, JK) + &
+ (PUMF(JI, JK) - PUER(JI, JK)) * ZWORK1(JI)
+ PUER(JI, JK) = PUER(JI, JK) * (1.-ZWORK1(JI))
+ PUMF(JI, JK) = PUMF(JI, JK) * (1.-ZWORK1(JI))
+ JKP = KCTL(JI) + 1
+ PUER(JI, JKP) = 0. ! entrainm/detr rates have been already computed
+ PUDR(JI, JKP) = 0. ! at level KCTL+1, set them to zero
+ PURW(JI, JKP) = 0.
+ PURC(JI, JKP) = 0.
+ PURI(JI, JKP) = 0.
+ PUTHL(JI, JKP) = 0.
+ PURI(JI, JKP + 1) = 0.
+ PURC(JI, JKP + 1) = 0.
+ enddo
+!
+!* 12.3 Adjust mass flux profiles, detrainment rates, and
+! precipitation fallout rates to reflect linear decrease
+! in mass flux between the ETL and CTL
+! -------------------------------------------------------
+!
+ ZWORK1(:) = 0.
+ JK1 = MINVAL(KETL(:))
+ JK2 = MAXVAL(KCTL(:))
+ do JK = JK1, JK2
+ do JI = 1, IIE
+ if(JK > KETL(JI) .and. JK <= KCTL(JI)) then
+ ZWORK1(JI) = ZWORK1(JI) + PDPRES(JI, JK)
+ endif
+ enddo
+ enddo
+!
+ do JI = 1, IIE
+ JK = KETL(JI)
+ ZWORK1(JI) = PUMF(JI, JK) / MAX(1., ZWORK1(JI))
+ enddo
+!
+ do JK = JK1 + 1, JK2
+ JKP = JK - 1
+ do JI = 1, IIE
+ if(JK > KETL(JI) .and. JK <= KCTL(JI)) then
+ ! PUTPR(JI) = PUTPR(JI) - ( PURR(JI,JK) + PURS(JI,JK) ) * PUMF(JI,JKP)
+ PUTPR(JI) = PUTPR(JI) - PUPR(JI, JK)
+ PUDR(JI, JK) = PDPRES(JI, JK) * ZWORK1(JI)
+ PUMF(JI, JK) = PUMF(JI, JKP) - PUDR(JI, JK)
+ PUPR(JI, JK) = PUMF(JI, JKP) * (PURR(JI, JK) + PURS(JI, JK))
+ PUTPR(JI) = PUTPR(JI) + PUPR(JI, JK)
+ endif
+ enddo
+ enddo
+!
+! 12.4 Set mass flux and entrainment in the source layer.
+! Linear increase throughout the source layer.
+! -------------------------------------------------------
+!
+!IWORK(:) = MIN( KPBL(:), KLCL(:) - 1 )
+ IWORK(:) = KPBL(:)
+ do JI = 1, IIE
+ JK = KDPL(JI)
+ JKP = IWORK(JI)
+! mixed layer depth
+ ZWORK2(JI) = PPRES(JI, JK) - PPRES(JI, JKP) + PDPRES(JI, JK)
+ enddo
+!
+ JKP = MAXVAL(IWORK(:))
+ do JK = JKM, JKP
+ do JI = 1, IIE
+ if(JK >= KDPL(JI) .and. JK <= IWORK(JI)) then
+ PUER(JI, JK) = PUER(JI, JK) + PMFLCL(JI) * PDPRES(JI, JK) / (ZWORK2(JI) + 0.1)
+ PUMF(JI, JK) = PUMF(JI, JK - 1) + PUER(JI, JK)
+ endif
+ enddo
+ enddo
+!
+!
+!* 13. If cloud thickness is smaller than 3 km, no
+! convection is allowed
+! Nota: For technical reasons, we stop the convection
+! computations in this case and do not go back to
+! TRIGGER_FUNCT to look for the next unstable LCL
+! which could produce a thicker cloud.
+! ---------------------------------------------------
+!
+ GWORK6(:, :) = SPREAD(OTRIG(:), DIM=2, NCOPIES=KLEV)
+ WHERE(.not. OTRIG(:)) PUTPR(:) = 0.
+ WHERE(.not. GWORK6(:, :))
+ PUMF(:, :) = 0.
+ PUDR(:, :) = 0.
+ PUER(:, :) = 0.
+ PUTHL(:, :) = PTHL(:, :)
+ PURW(:, :) = PRW(:, :)
+ PUPR(:, :) = 0.
+ PURC(:, :) = 0.
+ PURI(:, :) = 0.
+ PURR(:, :) = 0.
+ PURS(:, :) = 0.
+ ENDWHERE
+!
+ENDsubroutine CONVECT_UPDRAFT
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_TSTEP_PREF
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_TSTEP_PREF(KLON, KLEV, &
+ PU, PV, PPRES, PZ, PDXDY, KLCL, KCTL, &
+ PTIMEA, PPREF)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PU ! grid scale horiz. wind u
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PV ! grid scale horiz. wind v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m^2)
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! lifting condensation level index
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! cloud top level index
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTIMEA ! advective time period
+ REAL, DIMENSION(KLON), INTENT(OUT):: PPREF ! precipitation efficiency
+!
+ ENDsubroutine CONVECT_TSTEP_PREF
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_TSTEP_PREF
+! ######################################################################
+subroutine CONVECT_TSTEP_PREF(KLON, KLEV, &
+ PU, PV, PPRES, PZ, PDXDY, KLCL, KCTL, &
+ PTIMEA, PPREF)
+! ######################################################################
+!
+!!**** Routine to compute convective advection time step and precipitation
+!! efficiency
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the convective
+!! advection time step PTIMEC as a function of the mean ambient
+!! wind as well as the precipitation efficiency as a function
+!! of wind shear and cloud base height.
+!!
+!!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation
+!! Fritsch and Chappell, 1980, J. Atmos. Sci.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAREXT
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PU ! grid scale horiz. wind u
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PV ! grid scale horiz. wind v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m^2)
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! lifting condensation level index
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! cloud top level index
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTIMEA ! advective time period
+ REAL, DIMENSION(KLON), INTENT(OUT):: PPREF ! precipitation efficiency
+!
+!
+!* 0.2 Declarations of local variables KLON
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: JK, JKLC, JKP5, JKCT ! vertical loop index
+!
+ INTEGER, DIMENSION(KLON) :: IP500 ! index of 500 hPa levels
+ REAL, DIMENSION(KLON) :: ZCBH ! cloud base height
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3 ! work arrays
+!
+!
+!-------------------------------------------------------------------------------
+!
+! 0.3 Set loop bounds
+! ---------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Determine vertical index for 500 hPa levels
+! ------------------------------------------
+!
+!
+ IP500(:) = IKB
+ do JK = IKB, IKE
+ WHERE(PPRES(:, JK) >= 500.E2) IP500(:) = JK
+ enddo
+!
+!
+!* 2. Compute convective time step
+! ----------------------------
+!
+ ! compute wind speed at LCL, 500 hPa, CTL
+
+ do JI = 1, IIE
+ JKLC = KLCL(JI)
+ JKP5 = IP500(JI)
+ JKCT = KCTL(JI)
+ ZWORK1(JI) = SQRT(PU(JI, JKLC) * PU(JI, JKLC) + &
+ PV(JI, JKLC) * PV(JI, JKLC))
+ ZWORK2(JI) = SQRT(PU(JI, JKP5) * PU(JI, JKP5) + &
+ PV(JI, JKP5) * PV(JI, JKP5))
+ ZWORK3(JI) = SQRT(PU(JI, JKCT) * PU(JI, JKCT) + &
+ PV(JI, JKCT) * PV(JI, JKCT))
+ enddo
+!
+ ZWORK2(:) = MAX(0.1, 0.5 * (ZWORK1(:) + ZWORK2(:)))
+!
+ PTIMEA(:) = SQRT(PDXDY(:)) / ZWORK2(:)
+!
+!
+!* 3. Compute precipitation efficiency
+! -----------------------------------
+!
+!* 3.1 Precipitation efficiency as a function of wind shear
+! ----------------------------------------------------
+!
+ ZWORK2(:) = SIGN(1., ZWORK3(:) - ZWORK1(:))
+ do JI = 1, IIE
+ JKLC = KLCL(JI)
+ JKCT = KCTL(JI)
+ ZWORK1(JI) = (PU(JI, JKCT) - PU(JI, JKLC)) * &
+ (PU(JI, JKCT) - PU(JI, JKLC)) + &
+ (PV(JI, JKCT) - PV(JI, JKLC)) * &
+ (PV(JI, JKCT) - PV(JI, JKLC))
+ ZWORK1(JI) = 1.E3 * ZWORK2(JI) * SQRT(ZWORK1(JI)) / &
+ MAX(1.E-2, PZ(JI, JKCT) - PZ(JI, JKLC))
+ enddo
+!
+ PPREF(:) = 1.591 + ZWORK1(:) * (-.639 + ZWORK1(:) * ( &
+ 9.53E-2 - ZWORK1(:) * 4.96E-3))
+ PPREF(:) = MAX(.4, MIN(PPREF(:), .9))
+!
+!* 3.2 Precipitation efficiency as a function of cloud base height
+! ----------------------------------------------------------
+!
+ do JI = 1, IIE
+ JKLC = KLCL(JI)
+ ZCBH(JI) = MAX(3.,(PZ(JI, JKLC) - PZ(JI, IKB)) * 3.281E-3)
+ enddo
+ ZWORK1(:) = .9673 + ZCBH(:) * (-.7003 + ZCBH(:) * (.1622 + &
+ ZCBH(:) * (-1.2570E-2 + ZCBH(:) * (4.2772E-4 - &
+ ZCBH(:) * 5.44E-6))))
+ ZWORK1(:) = MAX(.4, MIN(.9, 1./(1.+ZWORK1(:))))
+!
+!* 3.3 Mean precipitation efficiency is used to compute rainfall
+! ----------------------------------------------------------
+!
+ PPREF(:) = 0.5 * (PPREF(:) + ZWORK1(:))
+!
+!
+ENDsubroutine CONVECT_TSTEP_PREF
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_DOWNDRAFT
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_DOWNDRAFT(KLON, KLEV, &
+ KICE, PPRES, PDPRES, PZ, PTH, PTHES, &
+ PRW, PRC, PRI, &
+ PPREF, KLCL, KCTL, KETL, &
+ PUTHL, PURW, PURC, PURI, &
+ PDMF, PDER, PDDR, PDTHL, PDRW, &
+ PMIXF, PDTEVR, KLFS, KDBL, KML, &
+ PDTEVRF)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! grid scale saturated theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c (cloud water)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i (cloud ice)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! level height (m)
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KETL ! contains vert. index of
+ ! equilibrium (zero buoyancy) level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KML ! " vert. index of melting level
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURC ! updraft r_c (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURI ! updraft r_i (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPREF ! precipitation efficiency
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDRW ! downdraft total water (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PMIXF ! mixed fraction at LFS
+ REAL, DIMENSION(KLON), INTENT(OUT):: PDTEVR ! total downdraft evaporation
+ ! rate at LFS (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDTEVRF! downdraft evaporation rate
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KLFS ! contains vert. index of LFS
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KDBL ! contains vert. index of DBL
+!
+ ENDsubroutine CONVECT_DOWNDRAFT
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_DOWNDRAFT
+! ##########################################################################
+subroutine CONVECT_DOWNDRAFT(KLON, KLEV, &
+ KICE, PPRES, PDPRES, PZ, PTH, PTHES, &
+ PRW, PRC, PRI, &
+ PPREF, KLCL, KCTL, KETL, &
+ PUTHL, PURW, PURC, PURI, &
+ PDMF, PDER, PDDR, PDTHL, PDRW, &
+ PMIXF, PDTEVR, KLFS, KDBL, KML, &
+ PDTEVRF)
+! ##########################################################################
+!
+!!**** Compute downdraft properties from LFS to DBL.
+!!
+!!
+!! PDRPOSE
+!! -------
+!! The purpose of this routine is to determine downdraft properties
+!! ( mass flux, thermodynamics )
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from top.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Routine CONVECT_SATMIXRATIO
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XPI ! Pi
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD ! Cpd (dry air)
+!! XCPV, XCL, XCI ! Cp of water vapor, liquid water and ice
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporisation/sublimation heat at XTT
+!!
+!! Module MODD_CONVPAR
+!! XCRAD ! cloud radius
+!! XZPBL ! thickness of downdraft detrainment layer
+!! XENTR ! entrainment constant in pressure coordinates
+!! XRHDBC ! relative humidity in downdraft below cloud
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_DOWNDRAFT)
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!! C.Lac 27/09/10 modification loop index for reproducibility
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR
+ USE MODD_CONVPAREXT
+!
+ USE MODI_CONVECT_SATMIXRATIO
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! grid scale saturated theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c (cloud water)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i (cloud ice)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! level height (m)
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KETL ! contains vert. index of
+ ! equilibrium (zero buoyancy) level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KML ! " vert. index of melting level
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURC ! updraft r_c (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURI ! updraft r_i (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPREF ! precipitation efficiency
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDRW ! downdraft total water (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PMIXF ! mixed fraction at LFS
+ REAL, DIMENSION(KLON), INTENT(OUT):: PDTEVR ! total downdraft evaporation
+ ! rate at LFS (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PDTEVRF! downdraft evaporation rate
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KLFS ! contains vert. index of LFS
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KDBL ! contains vert. index of DBL
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ INTEGER :: JK, JKP, JKM, JKT ! vertical loop index
+ INTEGER :: JI, JL ! horizontal loop index
+ INTEGER :: JITER ! iteration loop index
+ real :: ZRDOCP ! R_d / C_pd
+ real :: ZEPS ! R_d / R_v
+!
+ INTEGER, DIMENSION(KLON) :: IDDT ! top level of detrainm. layer
+ REAL, DIMENSION(KLON) :: ZTHE ! environm. theta_e (K)
+ REAL, DIMENSION(KLON) :: ZDT, ZDTP ! downdraft temperature (K)
+ REAL, DIMENSION(KLON) :: ZCPH ! specific heat C_ph
+ REAL, DIMENSION(KLON) :: ZLV, ZLS ! latent heat of vaporis., sublim.
+ REAL, DIMENSION(KLON) :: ZDDT ! thickness (hPa) of detrainm. layer
+ REAL, DIMENSION(KLON) :: ZPI ! Pi=(P0/P)**(Rd/Cpd)
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, ZWORK4 ! work arrays
+ LOGICAL, DIMENSION(KLON) :: GWORK1 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+! 0.3 Set loop bounds
+! ---------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Initialize downdraft properties
+! -------------------------------
+!
+ ZRDOCP = XRD / XCPD
+ ZEPS = XRD / XRV
+ PDMF(:, :) = 0.
+ PDER(:, :) = 0.
+ PDDR(:, :) = 0.
+ PDRW(:, :) = 0.
+ PDTHL(:, :) = 0.
+ PDTEVR(:) = 0.
+ PMIXF(:) = 0.
+ ZTHE(:) = 0.
+ ZDDT(:) = PDPRES(:, IKB + 2)
+ KDBL(:) = IKB + 1
+ KLFS(:) = IKB + 1
+ IDDT(:) = KDBL(:) + 1
+!
+!
+!* 2. Determine the LFS by looking for minimum of environmental
+! saturated theta_e
+! ----------------------------------------------------------
+!
+ ZWORK1(:) = 900. ! starting value for search of minimum envir. theta_e
+ do JK = MINVAL(KLCL(:)) + 2, MAXVAL(KETL(:))
+ do JI = 1, IIE
+ GWORK1(JI) = JK >= KLCL(JI) + 2 .and. JK < KETL(JI)
+ if(GWORK1(JI) .and. ZWORK1(JI) > PTHES(JI, JK)) then
+ KLFS(JI) = JK
+ ZWORK1(JI) = MIN(ZWORK1(JI), PTHES(JI, JK))
+ endif
+ enddo
+ enddo
+!
+!
+!* 3. Determine the mixed fraction using environmental and updraft
+! values of theta_e at LFS
+! ---------------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KLFS(JI)
+ ZPI(JI) = (XP00 / PPRES(JI, JK))**ZRDOCP
+ ! compute updraft theta_e
+ ZWORK3(JI) = PURW(JI, JK) - PURC(JI, JK) - PURI(JI, JK)
+ ZDT(JI) = PTH(JI, JK) / ZPI(JI)
+ ZLV(JI) = XLVTT + (XCPV - XCL) * (ZDT(JI) - XTT)
+ ZLS(JI) = XLSTT + (XCPV - XCI) * (ZDT(JI) - XTT)
+ ZCPH(JI) = XCPD + XCPV * PURW(JI, JK)
+ ZDT(JI) = (PUTHL(JI, JK) - (1.+PURW(JI, JK)) * XG * PZ(JI, JK) &
+ + ZLV(JI) * PURC(JI, JK) + ZLS(JI) * PURI(JI, JK)) / ZCPH(JI)
+ ZWORK1(JI) = ZDT(JI) * ZPI(JI)**(1.-0.28 * ZWORK3(JI)) &
+ * EXP((3374.6525 / ZDT(JI) - 2.5403) &
+ * ZWORK3(JI) * (1.+0.81 * ZWORK3(JI)))
+ ! compute environmental theta_e
+ ZDT(JI) = PTH(JI, JK) / ZPI(JI)
+ ZLV(JI) = XLVTT + (XCPV - XCL) * (ZDT(JI) - XTT)
+ ZLS(JI) = XLSTT + (XCPV - XCI) * (ZDT(JI) - XTT)
+ ZWORK3(JI) = PRW(JI, JK) - PRC(JI, JK) - PRI(JI, JK)
+ ZCPH(JI) = XCPD + XCPV * PRW(JI, JK)
+ ZWORK2(JI) = ZDT(JI) * ZPI(JI)**(1.-0.28 * ZWORK3(JI)) &
+ * EXP((3374.6525 / ZDT(JI) - 2.5403) &
+ * ZWORK3(JI) * (1.+0.81 * ZWORK3(JI)))
+ ! compute mixed fraction
+ PMIXF(JI) = MAX(0.,(ZWORK1(JI) - PTHES(JI, JK))) &
+ / (ZWORK1(JI) - ZWORK2(JI) + 1.E-10)
+ PMIXF(JI) = MAX(0., MIN(1., PMIXF(JI)))
+ ZWORK4(JI) = PPRES(JI, JK)
+ enddo
+!
+!
+!* 4. Estimate the effect of melting on the downdraft
+! ---------------------------------------------
+!
+ ZWORK1(:) = 0.
+ ! use total solid precipitation
+!do JK = IKB + 1, IKE
+! ZWORK1(:) = ZWORK1(:) + PURS(:,JK) ! total snow/hail content
+!end do
+!
+ do JI = 1, IIE
+ JK = KLCL(JI)
+ JKP = KCTL(JI)
+ ZWORK1(JI) = 0.5 * (PURW(JI, JK) - PURW(JI, JKP))
+ enddo
+!
+ ! temperature perturbation due to melting at LFS
+ ZWORK3(:) = 0.
+ WHERE(KML(:) > IKB + 2)
+ ZWORK3(:) = ZWORK1(:) * (ZLS(:) - ZLV(:)) / ZCPH(:)
+ ZDT(:) = ZDT(:) - ZWORK3(:) * REAL(KICE)
+ ENDWHERE
+!
+!
+!* 5. Initialize humidity at LFS as a saturated mixture of
+! updraft and environmental air
+! -----------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KLFS(JI)
+ PDRW(JI, JK) = PMIXF(JI) * PRW(JI, JK) + (1.-PMIXF(JI)) * PURW(JI, JK)
+ ZWORK2(JI) = PDRW(JI, JK) - (1.-PMIXF(JI)) &
+ * (PURC(JI, JK) + PURI(JI, JK))
+ enddo
+!
+!
+!* 6.1 Determine the DBL by looking for level where the envir.
+! theta_es at the LFS corrected by melting effects becomes
+! larger than envir. value
+! ---------------------------------------------------------
+!
+ ! compute satur. mixing ratio for melting corrected temperature
+ call CONVECT_SATMIXRATIO(KLON, ZWORK4, ZDT, ZWORK3, ZLV, ZLS, ZCPH)
+!
+ ! compute envir. saturated theta_e for melting corrected temperature
+ ZWORK1(:) = MIN(ZWORK2(:), ZWORK3(:))
+ ZWORK3(:) = ZWORK3(:) * ZWORK4(:) / (ZWORK3(:) + ZEPS) ! sat. pressure
+ ZWORK3(:) = ALOG(ZWORK3(:) / 613.3)
+ ! dewp point temperature
+ ZWORK3(:) = (4780.8 - 32.19 * ZWORK3(:)) / (17.502 - ZWORK3(:))
+ ! adiabatic saturation temperature
+ ZWORK3(:) = ZWORK3(:) - (.212 + 1.571E-3 * (ZWORK3(:) - XTT) &
+ - 4.36E-4 * (ZDT(:) - XTT)) * (ZDT(:) - ZWORK3(:))
+ ZWORK4(:) = SIGN(0.5, ZWORK2(:) - ZWORK3(:))
+ ZDT(:) = ZDT(:) * (.5 + ZWORK4(:)) + (.5 - ZWORK4(:)) * ZWORK3(:)
+ ZWORK2(:) = ZDT(:) * ZPI(:)**(1.-0.28 * ZWORK2(:)) &
+ * EXP((3374.6525 / ZDT(:) - 2.5403) &
+ * ZWORK1(:) * (1.+0.81 * ZWORK1(:)))
+!
+ GWORK1(:) = .true.
+ JKM = MAXVAL(KLFS(:))
+ do JK = JKM - 1, IKB + 1, -1
+ do JI = 1, IIE
+ if(JK < KLFS(JI) .and. ZWORK2(JI) > PTHES(JI, JK) .and. GWORK1(JI)) then
+ KDBL(JI) = JK
+ GWORK1(JI) = .false.
+ endif
+ enddo
+ enddo
+!
+!
+!* 7. Define mass flux and entr/detr. rates at LFS
+! -------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KLFS(JI)
+ ZWORK1(JI) = PPRES(JI, JK) / &
+ (XRD * ZDT(JI) * (1.+ZEPS * ZWORK1(JI))) ! density
+ PDMF(JI, JK) = -(1.-PPREF(JI)) * ZWORK1(JI) * XPI * XCRAD * XCRAD
+ PDTHL(JI, JK) = ZWORK2(JI) ! theta_l is here actually theta_e
+ ZWORK2(JI) = PDMF(JI, JK)
+ PDDR(JI, JK) = 0.
+ PDER(JI, JK) = -PMIXF(JI) * PDMF(JI, JK)
+ enddo
+!
+!
+! 7.1 Downdraft detrainment is assumed to occur in a layer
+! of 60 hPa, determine top level IDDT of this layer
+! ---------------------------------------------------------
+!
+ ZWORK1(:) = 0.
+ do JK = IKB + 2, JKM
+ ZWORK1(:) = ZWORK1(:) + PDPRES(:, JK)
+ !WHERE ( JK > KDBL(:) .and. ZWORK1(:) <= XZPBL )
+ WHERE(JK > KDBL(:) .and. JK <= KLCL(:))
+ ZDDT(:) = ZWORK1(:)
+ IDDT(:) = JK
+ ENDWHERE
+ enddo
+!
+!
+!* 8. Enter loop for downdraft computations. Make a first guess
+! of initial downdraft mass flux.
+! In the downdraft computations we use theta_es instead of
+! enthalpy as it allows to better take into account evaporation
+! effects. As the downdraft detrainment rate is zero apart
+! from the detrainment layer, we just compute enthalpy
+! downdraft from theta_es in this layer.
+! ----------------------------------------------------------
+!
+!
+!
+ do JK = JKM - 1, IKB + 1, -1
+ JKP = JK + 1
+ do JI = 1, IIE
+ if(JK < KLFS(JI) .and. JK >= IDDT(JI)) then
+ PDER(JI, JK) = -ZWORK2(JI) * XENTR * PDPRES(JI, JKP) / XCRAD
+ ! DER and DPRES are positive
+ PDMF(JI, JK) = PDMF(JI, JKP) - PDER(JI, JK)
+ ZPI(JI) = (XP00 / PPRES(JI, JK))**ZRDOCP
+ ZDT(JI) = PTH(JI, JK) / ZPI(JI)
+ ZWORK1(JI) = PRW(JI, JK) - PRC(JI, JK) - PRI(JI, JK)
+ ZTHE(JI) = ZDT(JI) * ZPI(JI)**(1.-0.28 * ZWORK1(JI)) &
+ * EXP((3374.6525 / ZDT(JI) - 2.5403) &
+ * ZWORK1(JI) * (1.+0.81 * ZWORK1(JI)))
+ ! PDTHL is here theta_es, later on in this routine this table is
+ ! reskipped to enthalpy
+ PDTHL(JI, JK) = (PDTHL(JI, JKP) * PDMF(JI, JKP) - ZTHE(JI) * PDER(JI, JK) &
+ ) / (PDMF(JI, JK) - 1.E-7)
+ PDRW(JI, JK) = (PDRW(JI, JKP) * PDMF(JI, JKP) - PRW(JI, JK) * PDER(JI, JK) &
+ ) / (PDMF(JI, JK) - 1.E-7)
+ endif
+ if(JK < IDDT(JI) .and. JK >= KDBL(JI)) then
+ JL = IDDT(JI)
+ PDDR(JI, JK) = -PDMF(JI, JL) * PDPRES(JI, JKP) / ZDDT(JI)
+ PDMF(JI, JK) = PDMF(JI, JKP) + PDDR(JI, JK)
+ PDTHL(JI, JK) = PDTHL(JI, JKP)
+ PDRW(JI, JK) = PDRW(JI, JKP)
+ endif
+ enddo
+ enddo
+!
+!
+!* 9. Calculate total downdraft evaporation
+! rate for given mass flux (between DBL and IDDT)
+! -----------------------------------------------
+!
+ PDTEVRF(:, :) = 0.
+! Reproducibility
+!JKT = MAXVAL( IDDT(:) )
+!do JK = IKB + 1, JKT
+ do JK = IKB + 1, IKE
+!
+ ZPI(:) = (XP00 / PPRES(:, JK))**ZRDOCP
+ ZDT(:) = PTH(:, JK) / ZPI(:)
+!
+!* 9.1 Determine wet bulb temperature at DBL from theta_e.
+! The iteration algoritm is similar to that used in
+! routine CONVECT_CONDENS
+! --------------------------------------------------
+!
+ do JITER = 1, 4
+ call CONVECT_SATMIXRATIO(KLON, PPRES(:, JK), ZDT, ZWORK1, ZLV, ZLS, ZCPH)
+ ZDTP(:) = PDTHL(:, JK) / (ZPI(:)**(1.-0.28 * ZWORK1(:)) &
+ * EXP((3374.6525 / ZDT(:) - 2.5403) &
+ * ZWORK1(:) * (1.+0.81 * ZWORK1(:))))
+ ZDT(:) = 0.4 * ZDTP(:) + 0.6 * ZDT(:) ! force convergence
+ enddo
+!
+!
+!* 9.2 Sum total downdraft evaporation rate. No evaporation
+! if actual humidity is larger than specified one.
+! -----------------------------------------------------
+!
+ ZWORK2(:) = ZWORK1(:) / ZDT(:) * (XBETAW / ZDT(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = ZLV(:) / ZCPH(:) * ZWORK1(:) * (1.-XRHDBC) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:)) ! temperature perturb ! due to evaporation
+ ZDT(:) = ZDT(:) + ZWORK2(:)
+!
+ call CONVECT_SATMIXRATIO(KLON, PPRES(:, JK), ZDT, ZWORK3, ZLV, ZLS, ZCPH)
+!
+ ZWORK3(:) = ZWORK3(:) * XRHDBC
+ ZWORK1(:) = MAX(0., ZWORK3(:) - PDRW(:, JK))
+ PDTEVR(:) = PDTEVR(:) + ZWORK1(:) * PDDR(:, JK)
+ PDTEVRF(:, JK) = PDTEVRF(:, JK) + ZWORK1(:) * PDDR(:, JK)
+ ! compute enthalpie and humidity in the detrainment layer
+ PDRW(:, JK) = MAX(PDRW(:, JK), ZWORK3(:))
+ PDTHL(:, JK) = ((XCPD + PDRW(:, JK) * XCPV) * ZDT(:) &
+ + (1.+PDRW(:, JK)) * XG * PZ(:, JK))
+!
+ enddo
+!
+!
+!* 12. If downdraft does not evaporate any water for specified
+! relative humidity, no downdraft is allowed
+! ---------------------------------------------------------
+!
+ ZWORK2(:) = 1.
+ WHERE(PDTEVR(:) < 1. .OR. KLFS(:) == IKB + 1) ZWORK2(:) = 0.
+ do JK = IKB, JKM
+ KDBL(:) = KDBL(:) * INT(ZWORK2(:)) + (1 - INT(ZWORK2(:))) * IKB
+ KLFS(:) = KLFS(:) * INT(ZWORK2(:)) + (1 - INT(ZWORK2(:))) * IKB
+ PDMF(:, JK) = PDMF(:, JK) * ZWORK2(:)
+ PDER(:, JK) = PDER(:, JK) * ZWORK2(:)
+ PDDR(:, JK) = PDDR(:, JK) * ZWORK2(:)
+ ZWORK1(:) = REAL(KLFS(:) - JK) ! use this to reset thl_d
+ ZWORK1(:) = MAX(0., MIN(1., ZWORK1(:))) ! and rv_d to zero above LFS
+ PDTHL(:, JK) = PDTHL(:, JK) * ZWORK2(:) * ZWORK1(:)
+ PDRW(:, JK) = PDRW(:, JK) * ZWORK2(:) * ZWORK1(:)
+ PDTEVR(:) = PDTEVR(:) * ZWORK2(:)
+ PDTEVRF(:, JK) = PDTEVRF(:, JK) * ZWORK2(:)
+ enddo
+!
+ENDsubroutine CONVECT_DOWNDRAFT
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_PRECIP_ADJUST
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_PRECIP_ADJUST(KLON, KLEV, &
+ PPRES, PUMF, PUER, PUDR, &
+ PUPR, PUTPR, PURW, &
+ PDMF, PDER, PDDR, PDTHL, PDRW, &
+ PPREF, PTPR, PMIXF, PDTEVR, &
+ KLFS, KDBL, KLCL, KCTL, KETL, &
+ PDTEVRF)
+
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PUTPR ! updraft total precipit. (kg/s
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPREF ! precipitation efficiency
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMIXF ! critical mixed fraction at LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KETL ! contains vert. index of equilibrium
+ ! (zero buoyancy) level
+ INTEGER, DIMENSION(KLON), INTENT(INOUT) :: KLFS ! contains vert. index of LFS
+ INTEGER, DIMENSION(KLON), INTENT(INOUT) :: KDBL ! contains vert. index of DBL
+!
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PDTEVR ! total downdraft evaporation
+ ! rate at LFS
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDTEVRF! downdraft evaporation rate
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUPR ! updraft precipit. (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDRW ! downdraft total water (kg/kg)
+!
+ REAL, DIMENSION(KLON), INTENT(OUT) :: PTPR ! total precipitation (kg/s)
+ ! = downdraft precipitation
+!
+ ENDsubroutine CONVECT_PRECIP_ADJUST
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_PRECIP_ADJUST
+! ######################################################################
+subroutine CONVECT_PRECIP_ADJUST(KLON, KLEV, &
+ PPRES, PUMF, PUER, PUDR, &
+ PUPR, PUTPR, PURW, &
+ PDMF, PDER, PDDR, PDTHL, PDRW, &
+ PPREF, PTPR, PMIXF, PDTEVR, &
+ KLFS, KDBL, KLCL, KCTL, KETL, &
+ PDTEVRF)
+! ######################################################################
+!
+!!**** Adjust up- and downdraft mass fluxes to be consistent with the
+!! mass transport at the LFS given by the precipitation efficiency
+!! relation.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to adjust up- and downdraft mass
+!! fluxes below the LFS to be consistent with the precipitation
+!! efficiency relation
+!!
+!!
+!!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! Module MODD_CONVPAR
+!! XUSRDPTH ! pressure depth to compute updraft humidity
+!! ! supply rate for downdraft
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_PRECIP_ADJUST)
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAREXT
+ USE MODD_CONVPAR
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PUTPR ! updraft total precipit. (kg/s
+ REAL, DIMENSION(KLON), INTENT(IN) :: PPREF ! precipitation efficiency
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMIXF ! critical mixed fraction at LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KETL ! contains vert. index of equilibrium
+ ! (zero buoyancy) level
+ INTEGER, DIMENSION(KLON), INTENT(INOUT) :: KLFS ! contains vert. index of LFS
+ INTEGER, DIMENSION(KLON), INTENT(INOUT) :: KDBL ! contains vert. index of DBL
+!
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PDTEVR ! total downdraft evaporation
+ ! rate at LFS
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDTEVRF! downdraft evaporation rate
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUPR ! updraft precipit. (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDRW ! downdraft total water (kg/kg)
+!
+ REAL, DIMENSION(KLON), INTENT(OUT) :: PTPR ! total precipitation (kg/s)
+ ! = downdraft precipitation
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ INTEGER :: JK, JKT1, JKT2, JKT3 ! vertical loop index
+ INTEGER :: JI ! horizontal loop index
+!
+ INTEGER, DIMENSION(KLON) :: IPRL
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, &
+ ZWORK4, ZWORK5, ZWORK6 ! work arrays
+!
+!
+!-------------------------------------------------------------------------------
+!
+! 0.3 Set loop bounds
+! ---------------
+!
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+ IIE = KLON
+ JKT1 = MAXVAL(KLFS(:))
+ JKT2 = MAXVAL(KCTL(:))
+ JKT3 = MINVAL(KLCL(:))
+!
+!
+! 1. Set some output variables for columns where no downdraft
+! exists. Exit if there is no downdraft at all.
+! --------------------------------------------------------
+!
+ IPRL(:) = IKB
+ PTPR(:) = 0.
+!
+ WHERE(PDTEVR(:) == 0.)
+ PTPR(:) = PUTPR(:) ! no downdraft evaporation => no downdraft, all
+ ! precipitation occurs in updraft
+ ENDWHERE
+ if(COUNT(PDTEVR(:) > 0.) == 0) then ! exit routine if no downdraft exists
+ RETURN
+ endif
+!
+!* 2. The total mass transported from the updraft to the down-
+! draft at the LFS must be consistent with the three water
+! budget terms :
+! ---------------------------------------------------------
+!
+!* 2.1 Downdraft evaporation rate at the DBL. The evaporation
+! rate in downdraft must be consistent with precipitation
+! efficiency relation.
+! --------------------------------------------------------
+!
+!
+ do JI = 1, IIE
+ JK = KLFS(JI)
+ ZWORK1(JI) = PDTEVR(JI) / MIN(-1.E-1, PDMF(JI, JK))
+ ZWORK6(JI) = PDMF(JI, JK)
+ enddo
+!
+!* 2.2 Some preliminar computations for downdraft = total
+! precipitation rate. The precipitation is evaluated in
+! a layer thickness DP=XUSRDPTH=165 hPa above the LCL.
+! The difference between updraft precipitation and downdraft
+! precipitation (updraft supply rate) is used to drive the
+! downdraft through evaporational cooling.
+! --------------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KLCL(JI)
+ ZWORK5(JI) = PPRES(JI, JK)
+ enddo
+!
+ PTPR(:) = 0.
+ do JK = JKT3, JKT2
+ WHERE(JK >= KLCL(:) .and. PPRES(:, JK) >= ZWORK5(:) - XUSRDPTH)
+ PTPR(:) = PTPR(:) + PUPR(:, JK)
+ IPRL(:) = JK
+ ENDWHERE
+ enddo
+ IPRL(:) = MIN(KETL(:), IPRL(:))
+!
+ do JI = 1, IIE
+ JK = IPRL(JI)
+ PTPR(JI) = PUMF(JI, JK + 1) * PURW(JI, JK + 1) + PTPR(JI)
+ enddo
+!
+ PTPR(:) = PPREF(:) * MIN(PUTPR(:), PTPR(:))
+ ZWORK4(:) = PUTPR(:) - PTPR(:)
+!
+!
+!* 2.3 Total amount of precipitation that falls out of the up-
+! draft between the LCL and the LFS.
+! Condensate transfer from up to downdraft at LFS
+! ---------------------------------------------------------
+!
+ ZWORK5(:) = 0.
+ do JK = JKT3, JKT1
+ WHERE(JK >= KLCL(:) .and. JK <= KLFS(:))
+ ZWORK5(:) = ZWORK5(:) + PUPR(:, JK)
+ ENDWHERE
+ enddo
+!
+ do JI = 1, IIE
+ JK = KLFS(JI)
+ ZWORK2(JI) = (1.-PPREF(JI)) * ZWORK5(JI) * &
+ (1.-PMIXF(JI)) / MAX(1.E-1, PUMF(JI, JK))
+ enddo
+!
+!
+!* 2.4 Increase the first guess downdraft mass flux to satisfy
+! precipitation efficiency relation.
+! If downdraft does not evaporate any water at the DBL for
+! the specified relative humidity, or if the corrected mass
+! flux at the LFS is positive no downdraft is allowed
+! ---------------------------------------------------------
+!
+!
+!ZWORK1(:) = ZWORK4(:) / ( ZWORK1(:) + ZWORK2(:) + 1.E-8 )
+ ZWORK1(:) = -ZWORK4(:) / (-ZWORK1(:) + ZWORK2(:) + 1.E-8)
+ ZWORK2(:) = ZWORK1(:) / MIN(-1.E-1, ZWORK6(:)) ! ratio of budget consistent to actual DMF
+!
+ ZWORK3(:) = 1.
+ ZWORK6(:) = 1.
+ WHERE(ZWORK1(:) > 0. .OR. PDTEVR(:) < 1.)
+ KDBL(:) = IKB
+ KLFS(:) = IKB
+ PDTEVR(:) = 0.
+ ZWORK2(:) = 0.
+ ZWORK3(:) = 0.
+ ZWORK6(:) = 0.
+ ENDWHERE
+!
+ do JK = IKB, JKT1
+ PDMF(:, JK) = PDMF(:, JK) * ZWORK2(:)
+ PDER(:, JK) = PDER(:, JK) * ZWORK2(:)
+ PDDR(:, JK) = PDDR(:, JK) * ZWORK2(:)
+ PDTEVRF(:, JK) = PDTEVRF(:, JK) * ZWORK2(:)
+ PDRW(:, JK) = PDRW(:, JK) * ZWORK3(:)
+ PDTHL(:, JK) = PDTHL(:, JK) * ZWORK3(:)
+ enddo
+ ZWORK4(:) = ZWORK2(:)
+!
+!
+!* 3. Increase updraft mass flux, mass detrainment rate, and water
+! substance detrainment rates to be consistent with the transfer
+! of the estimated mass from the up- to the downdraft at the LFS
+! --------------------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KLFS(JI)
+ ZWORK2(JI) = (1.-ZWORK6(JI)) + ZWORK6(JI) * &
+ (PUMF(JI, JK) - (1.-PMIXF(JI)) * ZWORK1(JI)) / &
+ MAX(1.E-1, PUMF(JI, JK))
+ enddo
+!
+!
+ JKT1 = MAXVAL(KLFS(:)) ! value of KLFS might have been reset to IKB above
+ do JK = IKB, JKT1
+ do JI = 1, IIE
+ if(JK <= KLFS(JI)) then
+ PUMF(JI, JK) = PUMF(JI, JK) * ZWORK2(JI)
+ PUER(JI, JK) = PUER(JI, JK) * ZWORK2(JI)
+ PUDR(JI, JK) = PUDR(JI, JK) * ZWORK2(JI)
+ PUPR(JI, JK) = PUPR(JI, JK) * ZWORK2(JI)
+ endif
+ enddo
+ enddo
+!
+!
+!* 4. Increase total = downdraft precipitation and evaporation rate
+! -------------------------------------------------------------
+!
+ WHERE(PDTEVR(:) > 0.)
+ PTPR(:) = PTPR(:) + PPREF(:) * ZWORK5(:) * (ZWORK2(:) - 1.)
+ PDTEVR(:) = PUTPR(:) - PTPR(:)
+ PDTEVRF(:, IKB + 1) = PDTEVR(:)
+ elseWHERE
+ PTPR(:) = PUTPR(:)
+ ENDWHERE
+!
+!
+ENDsubroutine CONVECT_PRECIP_ADJUST
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_CLOSURE_THRVLCL
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_CLOSURE_THRVLCL(KLON, KLEV, &
+ PPRES, PTH, PRV, PZ, OWORK1, &
+ PTHLCL, PRVLCL, PZLCL, PTLCL, PTELCL, &
+ KLCL, KDPL, KPBL)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! vapor mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of grid point (m)
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! " vert. index of source layer top
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OWORK1! logical mask
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTLCL ! temperature at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTELCL ! environm. temp. at LCL (K)
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KLCL ! contains vert. index of LCL
+!
+ ENDsubroutine CONVECT_CLOSURE_THRVLCL
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_CLOSURE_THRVLCL
+! #########################################################################
+subroutine CONVECT_CLOSURE_THRVLCL(KLON, KLEV, &
+ PPRES, PTH, PRV, PZ, OWORK1, &
+ PTHLCL, PRVLCL, PZLCL, PTLCL, PTELCL, &
+ KLCL, KDPL, KPBL)
+! #########################################################################
+!
+!!**** Determine thermodynamic properties at new LCL
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the thermodynamic
+!! properties at the new lifting condensation level LCL
+!!
+!!
+!!
+!!** METHOD
+!! ------
+!! see CONVECT_TRIGGER_FUNCT
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Routine CONVECT_SATMIXRATIO
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! Reference pressure
+!! XRD, XRV ! Gaz constants for dry air and water vapor
+!! XCPD ! Cpd (dry air)
+!! XTT ! triple point temperature
+!! XBETAW, XGAMW ! constants for vapor saturation pressure
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XZLCL ! lowest allowed pressure difference between
+!! ! surface and LCL
+!! XZPBL ! minimum mixed layer depth to sustain convection
+!! XWTRIG ! constant in vertical velocity trigger
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of documentation ( routine TRIGGER_FUNCT)
+!! Fritsch and Chappell (1980), J. Atm. Sci., Vol. 37, 1722-1761.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 04/10/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR
+ USE MODD_CONVPAREXT
+ USE MODI_CONVECT_SATMIXRATIO
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! vapor mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of grid point (m)
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! " vert. index of source layer top
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OWORK1! logical mask
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTLCL ! temperature at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTELCL ! environm. temp. at LCL (K)
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KLCL ! contains vert. index of LCL
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: JK, JKM, JKMIN, JKMAX ! vertical loop index
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ real :: ZEPS ! R_d / R_v
+ real :: ZCPORD, ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON) :: ZPLCL ! pressure at LCL
+ REAL, DIMENSION(KLON) :: ZTMIX ! mixed layer temperature
+ REAL, DIMENSION(KLON) :: ZEVMIX ! mixed layer water vapor pressure
+ REAL, DIMENSION(KLON) :: ZDPTHMIX, ZPRESMIX ! mixed layer depth and pressure
+ REAL, DIMENSION(KLON) :: ZLV, ZCPH! specific heats of vaporisation, dry air
+ REAL, DIMENSION(KLON) :: ZDP ! pressure between LCL and model layer
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2 ! work arrays
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.3 Compute array bounds
+! --------------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Initialize local variables
+! --------------------------
+!
+ ZEPS = XRD / XRV
+ ZCPORD = XCPD / XRD
+ ZRDOCP = XRD / XCPD
+!
+ ZDPTHMIX(:) = 0.
+ ZPRESMIX(:) = 0.
+ PTHLCL(:) = 300.
+ PTLCL(:) = 300.
+ PTELCL(:) = 300.
+ PRVLCL(:) = 0.
+ PZLCL(:) = PZ(:, IKB)
+ ZTMIX(:) = 230.
+ ZPLCL(:) = 1.E4
+ KLCL(:) = IKB + 1
+!
+!
+!* 2. Construct a mixed layer as in TRIGGER_FUNCT
+! -------------------------------------------
+!
+ JKMAX = MAXVAL(KPBL(:))
+ JKMIN = MINVAL(KDPL(:))
+ do JK = IKB + 1, JKMAX
+ JKM = JK + 1
+ do JI = 1, IIE
+ if(JK >= KDPL(JI) .and. JK <= KPBL(JI)) then
+!
+ ZWORK1(JI) = PPRES(JI, JK) - PPRES(JI, JKM)
+ ZDPTHMIX(JI) = ZDPTHMIX(JI) + ZWORK1(JI)
+ ZPRESMIX(JI) = ZPRESMIX(JI) + PPRES(JI, JK) * ZWORK1(JI)
+ PTHLCL(JI) = PTHLCL(JI) + PTH(JI, JK) * ZWORK1(JI)
+ PRVLCL(JI) = PRVLCL(JI) + PRV(JI, JK) * ZWORK1(JI)
+!
+ endif
+ enddo
+ enddo
+!
+!
+ WHERE(OWORK1(:))
+!
+ ZPRESMIX(:) = ZPRESMIX(:) / ZDPTHMIX(:)
+ PTHLCL(:) = PTHLCL(:) / ZDPTHMIX(:)
+ PRVLCL(:) = PRVLCL(:) / ZDPTHMIX(:)
+!
+!* 3.1 Use an empirical direct solution ( Bolton formula )
+! to determine temperature and pressure at LCL.
+! Nota: the adiabatic saturation temperature is not
+! equal to the dewpoint temperature
+! --------------------------------------------------
+!
+!
+ ZTMIX(:) = PTHLCL(:) * (ZPRESMIX(:) / XP00)**ZRDOCP
+ ZEVMIX(:) = PRVLCL(:) * ZPRESMIX(:) / (PRVLCL(:) + ZEPS)
+ ZEVMIX(:) = MAX(1.E-8, ZEVMIX(:))
+ ZWORK1(:) = ALOG(ZEVMIX(:) / 613.3)
+ ! dewpoint temperature
+ ZWORK1(:) = (4780.8 - 32.19 * ZWORK1(:)) / (17.502 - ZWORK1(:))
+ ! adiabatic saturation temperature
+ PTLCL(:) = ZWORK1(:) - (.212 + 1.571E-3 * (ZWORK1(:) - XTT) &
+ - 4.36E-4 * (ZTMIX(:) - XTT)) * (ZTMIX(:) - ZWORK1(:))
+ PTLCL(:) = MIN(PTLCL(:), ZTMIX(:))
+ ZPLCL(:) = XP00 * (PTLCL(:) / PTHLCL(:))**ZCPORD
+!
+ ENDWHERE
+!
+ ZPLCL(:) = MIN(2.E5, MAX(10., ZPLCL(:))) ! bound to avoid overflow
+!
+!
+!* 3.2 Correct PTLCL in order to be completely consistent
+! with MNH saturation formula
+! --------------------------------------------------
+!
+ call CONVECT_SATMIXRATIO(KLON, ZPLCL, PTLCL, ZWORK1, ZLV, ZWORK2, ZCPH)
+ WHERE(OWORK1(:))
+ ZWORK2(:) = ZWORK1(:) / PTLCL(:) * (XBETAW / PTLCL(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = (ZWORK1(:) - PRVLCL(:)) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:))
+ PTLCL(:) = PTLCL(:) - ZLV(:) / ZCPH(:) * ZWORK2(:)
+!
+ ENDWHERE
+!
+!
+!* 3.3 If PRVLCL is oversaturated set humidity and temperature
+! to saturation values.
+! -------------------------------------------------------
+!
+ call CONVECT_SATMIXRATIO(KLON, ZPRESMIX, ZTMIX, ZWORK1, ZLV, ZWORK2, ZCPH)
+ WHERE(OWORK1(:) .and. PRVLCL(:) > ZWORK1(:))
+ ZWORK2(:) = ZWORK1(:) / ZTMIX(:) * (XBETAW / ZTMIX(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = (ZWORK1(:) - PRVLCL(:)) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:))
+ PTLCL(:) = ZTMIX(:) + ZLV(:) / ZCPH(:) * ZWORK2(:)
+ PRVLCL(:) = PRVLCL(:) - ZWORK2(:)
+ ZPLCL(:) = ZPRESMIX(:)
+ PTHLCL(:) = PTLCL(:) * (XP00 / ZPLCL(:))**ZRDOCP
+ ENDWHERE
+!
+!
+!* 4.1 Determine vertical loop index at the LCL
+! -----------------------------------------
+!
+ do JK = JKMIN, IKE - 1
+ do JI = 1, IIE
+ if(ZPLCL(JI) <= PPRES(JI, JK) .and. OWORK1(JI)) then
+ KLCL(JI) = JK + 1
+ PZLCL(JI) = PZ(JI, JK + 1)
+ endif
+ enddo
+ enddo
+!
+!
+!* 4.2 Estimate height and environmental temperature at LCL
+! ----------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KLCL(JI)
+ JKM = JK - 1
+ ZDP(JI) = ALOG(ZPLCL(JI) / PPRES(JI, JKM)) / &
+ ALOG(PPRES(JI, JK) / PPRES(JI, JKM))
+ ZWORK1(JI) = PTH(JI, JK) * (PPRES(JI, JK) / XP00)**ZRDOCP
+ ZWORK2(JI) = PTH(JI, JKM) * (PPRES(JI, JKM) / XP00)**ZRDOCP
+ ZWORK1(JI) = ZWORK2(JI) + (ZWORK1(JI) - ZWORK2(JI)) * ZDP(JI)
+ ! we compute the precise value of the LCL
+ ! The precise height is between the levels KLCL and KLCL-1.
+ ZWORK2(JI) = PZ(JI, JKM) + (PZ(JI, JK) - PZ(JI, JKM)) * ZDP(JI)
+ enddo
+ WHERE(OWORK1(:))
+ PTELCL(:) = ZWORK1(:)
+ PZLCL(:) = ZWORK2(:)
+ ENDWHERE
+!
+!
+!
+ENDsubroutine CONVECT_CLOSURE_THRVLCL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_CLOSURE_ADJUST
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_CLOSURE_ADJUST(KLON, KLEV, PADJ, &
+ PUMF, PZUMF, PUER, PZUER, PUDR, PZUDR, &
+ PDMF, PZDMF, PDER, PZDER, PDDR, PZDDR, &
+ PPRMELT, PZPRMELT, PDTEVR, PZDTEVR, &
+ PTPR, PZTPR, &
+ PPRLFLX, PZPRLFL, PPRSFLX, PZPRSFL)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON), INTENT(IN) :: PADJ ! mass adjustment factor
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUMF ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUER ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUDR ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZDMF ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZDER ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZDDR ! initial value of "
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PTPR ! total precipitation (kg/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PZTPR ! initial value of "
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PDTEVR ! donwndraft evapor. (kg/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PZDTEVR ! initial value of "
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRMELT ! melting of precipitation
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PZPRMELT ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PPRLFLX! liquid precip flux
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZPRLFL! initial value "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PPRSFLX! solid precip flux
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZPRSFL! initial value "
+!
+ ENDsubroutine CONVECT_CLOSURE_ADJUST
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_CLOSURE_ADJUST
+! ###########################################################################
+subroutine CONVECT_CLOSURE_ADJUST(KLON, KLEV, PADJ, &
+ PUMF, PZUMF, PUER, PZUER, PUDR, PZUDR, &
+ PDMF, PZDMF, PDER, PZDER, PDDR, PZDDR, &
+ PPRMELT, PZPRMELT, PDTEVR, PZDTEVR, &
+ PTPR, PZTPR, &
+ PPRLFLX, PZPRLFL, PPRSFLX, PZPRSFL)
+! ###########################################################################
+!
+!!**** Uses closure adjustment factor to adjust mass flux and to modify
+!! precipitation efficiency when necessary. The computations are
+!! similar to routine CONVECT_PRECIP_ADJUST.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to adjust the mass flux using the
+!! factor PADJ computed in CONVECT_CLOSURE
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_CLOSURE_ADJUST)
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 04/10/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAREXT
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON), INTENT(IN) :: PADJ ! mass adjustment factor
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUMF ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUER ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUDR ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZDMF ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZDER ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZDDR ! initial value of "
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PTPR ! total precipitation (kg/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PZTPR ! initial value of "
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PDTEVR ! donwndraft evapor. (kg/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PZDTEVR ! initial value of "
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRMELT ! melting of precipitation
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PZPRMELT ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PPRLFLX! liquid precip flux
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZPRLFL! initial value "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PPRSFLX! solid precip flux
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZPRSFL! initial value "
+!
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IKB, IKE ! vert. loop bounds
+ INTEGER :: JK ! vertical loop index
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.3 Compute loop bounds
+! -------------------
+!
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Adjust mass flux by the factor PADJ to converge to
+! specified degree of stabilization
+! ----------------------------------------------------
+!
+ PPRMELT(:) = PZPRMELT(:) * PADJ(:)
+ PDTEVR(:) = PZDTEVR(:) * PADJ(:)
+ PTPR(:) = PZTPR(:) * PADJ(:)
+!
+ do JK = IKB + 1, IKE
+ PUMF(:, JK) = PZUMF(:, JK) * PADJ(:)
+ PUER(:, JK) = PZUER(:, JK) * PADJ(:)
+ PUDR(:, JK) = PZUDR(:, JK) * PADJ(:)
+ PDMF(:, JK) = PZDMF(:, JK) * PADJ(:)
+ PDER(:, JK) = PZDER(:, JK) * PADJ(:)
+ PDDR(:, JK) = PZDDR(:, JK) * PADJ(:)
+ PPRLFLX(:, JK) = PZPRLFL(:, JK) * PADJ(:)
+ PPRSFLX(:, JK) = PZPRSFL(:, JK) * PADJ(:)
+ enddo
+!
+ENDsubroutine CONVECT_CLOSURE_ADJUST
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_CLOSURE
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_CLOSURE(KLON, KLEV, &
+ PPRES, PDPRES, PZ, PDXDY, PLMASS, &
+ PTHL, PTH, PRW, PRC, PRI, OTRIG1, &
+ PTHC, PRWC, PRCC, PRIC, PWSUB, &
+ KLCL, KDPL, KPBL, KLFS, KCTL, KML, &
+ PUMF, PUER, PUDR, PUTHL, PURW, &
+ PURC, PURI, PUPR, &
+ PDMF, PDER, PDDR, PDTHL, PDRW, &
+ PTPR, PSPR, PDTEVR, &
+ PCAPE, PTIMEC, &
+ KFTSTEPS, &
+ PDTEVRF, PPRLFLX, PPRSFLX)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLFS ! index for level of free sink
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! index lifting condens. level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! index for cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! index for departure level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! index for top of source layer
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KML ! index for melting level
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PTIMEC ! convection time step
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m^2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OTRIG1 ! logical to keep trace of
+ ! convective arrays modified in UPDRAFT
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES ! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PLMASS ! mass of model layer (kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PCAPE ! available potent. energy
+ INTEGER, INTENT(OUT) :: KFTSTEPS! maximum of fract time steps
+ ! only used for chemical tracers
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUPR ! updraft precipitation in
+ ! flux units (kg water / s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURI ! updraft cloud ice (kg/kg)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDRW ! downdraft total water (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PTPR ! total surf precipitation (kg/s)
+ REAL, DIMENSION(KLON), INTENT(OUT) :: PSPR ! solid surf precipitation (kg/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PDTEVR! donwndraft evapor. (kg/s)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PTHC ! conv. adj. grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRWC ! conv. adj. grid scale r_w
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRCC ! conv. adj. grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRIC ! conv. adj. grid scale r_i
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PWSUB ! envir. compensating subsidence(Pa/s)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDTEVRF! downdraft evaporation rate
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PPRLFLX! liquid precip flux
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PPRSFLX! solid precip flux
+!
+ ENDsubroutine CONVECT_CLOSURE
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_CLOSURE
+! #########################################################################
+subroutine CONVECT_CLOSURE(KLON, KLEV, &
+ PPRES, PDPRES, PZ, PDXDY, PLMASS, &
+ PTHL, PTH, PRW, PRC, PRI, OTRIG1, &
+ PTHC, PRWC, PRCC, PRIC, PWSUB, &
+ KLCL, KDPL, KPBL, KLFS, KCTL, KML, &
+ PUMF, PUER, PUDR, PUTHL, PURW, &
+ PURC, PURI, PUPR, &
+ PDMF, PDER, PDDR, PDTHL, PDRW, &
+ PTPR, PSPR, PDTEVR, &
+ PCAPE, PTIMEC, &
+ KFTSTEPS, &
+ PDTEVRF, PPRLFLX, PPRSFLX)
+! #########################################################################
+!
+!!**** Uses modified Fritsch-Chappell closure
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the final adjusted
+!! (over a time step PTIMEC) environmental values of THETA_l, R_w, R_c, R_i
+!! The final convective tendencies can then be evaluated in the main
+!! routine DEEP_CONVECT by (PTHC-PTH)/PTIMEC
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! CONVECT_CLOSURE_THRVLCL
+!! CONVECT_CLOSURE_ADJUST
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV ! specific heat for dry air and water vapor
+!! XCL, XCI ! specific heat for liquid water and ice
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporization, sublimation heat constant
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XSTABT ! stability factor in time integration
+!! XSTABC ! stability factor in CAPE adjustment
+!! XMELDPTH ! allow melting over specific pressure depth
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_CLOSURE)
+!! Fritsch and Chappell, 1980, J. Atmos. Sci.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Peter Bechtold 04/10/97 change for enthalpie, r_c + r_i tendencies
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR
+ USE MODD_CONVPAREXT
+!
+ USE MODI_CONVECT_SATMIXRATIO
+ USE MODI_CONVECT_CLOSURE_THRVLCL
+ USE MODI_CONVECT_CLOSURE_ADJUST
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLFS ! index for level of free sink
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! index lifting condens. level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! index for cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! index for departure level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! index for top of source layer
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KML ! index for melting level
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PTIMEC ! convection time step
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m^2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OTRIG1 ! logical to keep trace of
+ ! convective arrays modified in UPDRAFT
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES ! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PLMASS ! mass of model layer (kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PCAPE ! available potent. energy
+ INTEGER, INTENT(OUT) :: KFTSTEPS! maximum of fract time steps
+ ! only used for chemical tracers
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUPR ! updraft precipitation in
+ ! flux units (kg water / s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURI ! updraft cloud ice (kg/kg)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDRW ! downdraft total water (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PTPR ! total surf precipitation (kg/s)
+ REAL, DIMENSION(KLON), INTENT(OUT) :: PSPR ! solid surf precipitation (kg/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PDTEVR! donwndraft evapor. (kg/s)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PTHC ! conv. adj. grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRWC ! conv. adj. grid scale r_w
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRCC ! conv. adj. grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRIC ! conv. adj. grid scale r_i
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PWSUB ! envir. compensating subsidence(Pa/s)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDTEVRF! downdraft evaporation rate
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PPRLFLX! liquid precip flux
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PPRSFLX! solid precip flux
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ INTEGER :: IKS ! vertical dimension
+ INTEGER :: JK, JKP, JKMAX ! vertical loop index
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: JITER ! iteration loop index
+ INTEGER :: JSTEP ! fractional time loop index
+ real :: ZCPORD, ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON, KLEV) :: ZTHLC ! convectively adjusted
+ ! grid scale enthalpy
+ REAL, DIMENSION(KLON, KLEV) :: ZOMG ! conv. environm. subsidence (Pa/s)
+ REAL, DIMENSION(KLON, KLEV) :: ZUMF ! non-adjusted updraft mass flux
+ REAL, DIMENSION(KLON, KLEV) :: ZUER ! " updraft entrainm. rate
+ REAL, DIMENSION(KLON, KLEV) :: ZUDR ! " updraft detrainm. rate
+ REAL, DIMENSION(KLON, KLEV) :: ZDMF ! " downdraft mass flux
+ REAL, DIMENSION(KLON, KLEV) :: ZDER ! " downdraft entrainm. rate
+ REAL, DIMENSION(KLON, KLEV) :: ZDDR ! " downdraft detrainm. rate
+ REAL, DIMENSION(KLON) :: ZTPR ! " total precipitation
+ REAL, DIMENSION(KLON) :: ZDTEVR ! " total downdraft evapor.
+ REAL, DIMENSION(KLON, KLEV):: ZPRLFLX ! " liquid precip flux
+ REAL, DIMENSION(KLON, KLEV):: ZPRSFLX ! " solid precip flux
+ REAL, DIMENSION(KLON) :: ZPRMELT ! melting of precipitation
+ REAL, DIMENSION(KLON) :: ZPRMELTO ! non-adjusted "
+ REAL, DIMENSION(KLON) :: ZADJ ! mass adjustment factor
+ REAL, DIMENSION(KLON) :: ZADJMAX ! limit value for ZADJ
+ REAL, DIMENSION(KLON) :: ZCAPE ! new CAPE after adjustment
+ REAL, DIMENSION(KLON) :: ZTIMEC ! fractional convective time step
+ REAL, DIMENSION(KLON, KLEV):: ZTIMC ! 2D work array for ZTIMEC
+!
+ REAL, DIMENSION(KLON) :: ZTHLCL ! new theta at LCL
+ REAL, DIMENSION(KLON) :: ZRVLCL ! new r_v at LCL
+ REAL, DIMENSION(KLON) :: ZZLCL ! height of LCL
+ REAL, DIMENSION(KLON) :: ZTLCL ! temperature at LCL
+ REAL, DIMENSION(KLON) :: ZTELCL ! envir. temper. at LCL
+ REAL, DIMENSION(KLON) :: ZTHEUL ! theta_e for undilute ascent
+ REAL, DIMENSION(KLON) :: ZTHES1, ZTHES2! saturation environm. theta_e
+ REAL, DIMENSION(KLON, KLEV) :: ZTHMFIN, ZTHMFOUT, ZRWMFIN, ZRWMFOUT
+ REAL, DIMENSION(KLON, KLEV) :: ZRCMFIN, ZRCMFOUT, ZRIMFIN, ZRIMFOUT
+ ! work arrays for environm. compensat. mass flux
+ REAL, DIMENSION(KLON) :: ZPI ! (P/P00)**R_d/C_pd
+ REAL, DIMENSION(KLON) :: ZLV ! latent heat of vaporisation
+ REAL, DIMENSION(KLON) :: ZLS ! latent heat of sublimation
+ REAL, DIMENSION(KLON) :: ZLM ! latent heat of melting
+ REAL, DIMENSION(KLON) :: ZCPH ! specific heat C_ph
+ REAL, DIMENSION(KLON) :: ZMELDPTH ! actual depth of melting layer
+ INTEGER, DIMENSION(KLON) :: ITSTEP ! fractional convective time step
+ INTEGER, DIMENSION(KLON) :: ICOUNT ! timestep counter
+ INTEGER, DIMENSION(KLON) :: ILCL ! index lifting condens. level
+ INTEGER, DIMENSION(KLON) :: IWORK1 ! work array
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, ZWORK4, ZWORK5
+ REAL, DIMENSION(KLON, KLEV):: ZWORK6
+ LOGICAL, DIMENSION(KLON) :: GWORK1, GWORK3! work arrays
+ LOGICAL, DIMENSION(KLON, KLEV) :: GWORK4 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.2 Initialize local variables
+! ----------------------------
+!
+!
+ PSPR(:) = 0.
+ ZTIMC(:, :) = 0.
+ ZTHES2(:) = 0.
+ ZWORK1(:) = 0.
+ ZWORK2(:) = 0.
+ ZWORK3(:) = 0.
+ ZWORK4(:) = 0.
+ ZWORK5(:) = 0.
+ GWORK1(:) = .false.
+ GWORK3(:) = .false.
+ GWORK4(:, :) = .false.
+ ILCL(:) = KLCL(:)
+!
+ ZCPORD = XCPD / XRD
+ ZRDOCP = XRD / XCPD
+!
+ ZADJ(:) = 1.
+ ZWORK5(:) = 1.
+ WHERE(.not. OTRIG1(:)) ZWORK5(:) = 0.
+!
+!
+!* 0.3 Compute loop bounds
+! -------------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKS = KLEV
+ IKE = KLEV - JCVEXT
+ JKMAX = MAXVAL(KCTL(:))
+!
+!
+!* 2. Save initial mass flux values to be used in adjustment procedure
+! ---------------------------------------------------------------
+!
+ ZUMF(:, :) = PUMF(:, :)
+ ZUER(:, :) = PUER(:, :)
+ ZUDR(:, :) = PUDR(:, :)
+ ZDMF(:, :) = PDMF(:, :)
+ ZDER(:, :) = PDER(:, :)
+ ZDDR(:, :) = PDDR(:, :)
+ ZTPR(:) = PTPR(:)
+ ZDTEVR(:) = PDTEVR(:)
+ ZOMG(:, :) = 0.
+ PWSUB(:, :) = 0.
+ ZPRMELT(:) = 0.
+ PPRLFLX(:, :) = 0.
+ ZPRLFLX(:, :) = 0.
+ PPRSFLX(:, :) = 0.
+ ZPRSFLX(:, :) = 0.
+!
+!
+!* 2.1 Some preliminar computations for melting of precipitation
+! used later in section 9 and computation of precip fluxes
+! Precipitation fluxes are updated for melting and evaporation
+! ---------------------------------------------------------
+!
+!
+ ZWORK1(:) = 0.
+ ZMELDPTH(:) = 0.
+ ZWORK6(:, :) = 0.
+ do JK = JKMAX + 1, IKB + 1, -1
+ ! Nota: PUPR is total precipitation flux, but the solid, liquid
+ ! precipitation is stored in units kg/kg; therefore we compute here
+ ! the solid fraction of the total precipitation flux.
+ do JI = 1, IIE
+ ZWORK2(JI) = PUPR(JI, JK) / (PURC(JI, JK) + PURI(JI, JK) + 1.E-8)
+ ZPRMELT(JI) = ZPRMELT(JI) + PURI(JI, JK) * ZWORK2(JI)
+ ZWORK1(JI) = ZWORK1(JI) + PURC(JI, JK) * ZWORK2(JI) - PDTEVRF(JI, JK)
+ ZPRLFLX(JI, JK) = MAX(0., ZWORK1(JI))
+ ZPRMELT(JI) = ZPRMELT(JI) + MIN(0., ZWORK1(JI))
+ ZPRSFLX(JI, JK) = ZPRMELT(JI)
+ if(KML(JI) >= JK .and. ZMELDPTH(JI) <= XMELDPTH) then
+ ZPI(JI) = (PPRES(JI, JK) / XP00)**ZRDOCP
+ ZWORK3(JI) = PTH(JI, JK) * ZPI(JI) ! temperature estimate
+ ZLM(JI) = XLSTT + (XCPV - XCI) * (ZWORK3(JI) - XTT) - &
+ (XLVTT + (XCPV - XCL) * (ZWORK3(JI) - XTT)) ! L_s - L_v
+ ZCPH(JI) = XCPD + XCPV * PRW(JI, JK)
+ ZMELDPTH(JI) = ZMELDPTH(JI) + PDPRES(JI, JK)
+ ZWORK6(JI, JK) = ZLM(JI) * PTIMEC(JI) / PLMASS(JI, JK) * PDPRES(JI, JK)
+ ZOMG(JI, JK) = 1. ! at this place only used as work variable
+ endif
+ enddo
+!
+ enddo
+!
+ ZWORK2(:) = 0.
+ do JK = JKMAX, IKB + 1, -1
+ ZWORK1(:) = ZPRMELT(:) * PDPRES(:, JK) / MAX(XMELDPTH, ZMELDPTH(:))
+ ZWORK2(:) = ZWORK2(:) + ZWORK1(:) * ZOMG(:, JK)
+ ZPRLFLX(:, JK) = ZPRLFLX(:, JK) + ZWORK2(:)
+ ZPRSFLX(:, JK) = ZPRSFLX(:, JK) - ZWORK2(:)
+ enddo
+ WHERE(ZPRSFLX(:, :) < 1.) ZPRSFLX(:, :) = 0.
+ ZPRMELTO(:) = ZPRMELT(:)
+!
+!
+!* 3. Compute limits on the closure adjustment factor so that the
+! inflow in convective drafts from a given layer can't be larger
+! than the mass contained in this layer initially.
+! ---------------------------------------------------------------
+!
+ ZADJMAX(:) = 1000.
+ IWORK1(:) = MAX(ILCL(:), KLFS(:))
+ JKP = MINVAL(KDPL(:))
+ do JK = JKP, IKE
+ do JI = 1, IIE
+ if(JK > KDPL(JI) .and. JK <= IWORK1(JI)) then
+ ZWORK1(JI) = PLMASS(JI, JK) / &
+ ((PUER(JI, JK) + PDER(JI, JK) + 1.E-5) * PTIMEC(JI))
+ ZADJMAX(JI) = MIN(ZADJMAX(JI), ZWORK1(JI))
+ endif
+ enddo
+ enddo
+!
+!
+ GWORK1(:) = OTRIG1(:) ! logical array to limit adjustment to not definitively
+ ! adjusted columns
+!
+ do JK = IKB, IKE
+ ZTHLC(:, JK) = PTHL(:, JK) ! initialize adjusted envir. values
+ PRWC(:, JK) = PRW(:, JK)
+ PRCC(:, JK) = PRC(:, JK)
+ PRIC(:, JK) = PRI(:, JK)
+ PTHC(:, JK) = PTH(:, JK)
+ enddo
+!
+!
+!
+ do JITER = 1, 6 ! Enter adjustment loop to assure that all CAPE is
+ ! removed within the advective time interval TIMEC
+!
+ ZTIMEC(:) = PTIMEC(:)
+ GWORK4(:, :) = SPREAD(GWORK1(:), DIM=2, NCOPIES=IKS)
+ WHERE(GWORK4(:, :)) PWSUB(:, :) = 0.
+ ZOMG(:, :) = 0.
+!
+ do JK = IKB + 1, JKMAX
+ JKP = MAX(IKB + 1, JK - 1)
+ WHERE(GWORK1(:) .and. JK <= KCTL(:))
+!
+!
+!* 4. Determine vertical velocity at top and bottom of each layer
+! to satisfy mass continuity.
+! ---------------------------------------------------------------
+ ! we compute here Domega/Dp = - g rho Dw/Dz = 1/Dt
+!
+ ZWORK1(:) = -(PUER(:, JKP) + PDER(:, JKP) - &
+ PUDR(:, JKP) - PDDR(:, JKP)) / PLMASS(:, JKP)
+!
+ PWSUB(:, JK) = PWSUB(:, JKP) - PDPRES(:, JK - 1) * ZWORK1(:)
+ ! we use PDPRES(JK-1) and not JKP in order to have zero subsidence
+ ! at the first layer
+!
+!
+!* 5. Compute fractional time step. For stability or
+! mass conservation reasons one must split full time step PTIMEC)
+! ---------------------------------------------------------------
+!
+ ZWORK1(:) = XSTABT * PDPRES(:, JKP) / (ABS(PWSUB(:, JK)) + 1.E-10)
+ ! the factor XSTABT is used for stability reasons
+ ZTIMEC(:) = MIN(ZTIMEC(:), ZWORK1(:))
+!
+ ! transform vertical velocity in mass flux units
+ ZOMG(:, JK) = PWSUB(:, JK) * PDXDY(:) / XG
+ ENDWHERE
+ enddo
+!
+!
+ WHERE(GWORK4(:, :))
+ ZTHLC(:, :) = PTHL(:, :) ! reinitialize adjusted envir. values
+ PRWC(:, :) = PRW(:, :) ! when iteration criterium not attained
+ PRCC(:, :) = PRC(:, :)
+ PRIC(:, :) = PRI(:, :)
+ PTHC(:, :) = PTH(:, :)
+ ENDWHERE
+!
+!
+! 6. Check for mass conservation, i.e. ZWORK1 > 1.E-2
+! If mass is not conserved, the convective tendencies
+! automatically become zero.
+! ----------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KCTL(JI)
+ ZWORK1(JI) = PUDR(JI, JK) * PDPRES(JI, JK) / (PLMASS(JI, JK) + .1) &
+ - PWSUB(JI, JK)
+ enddo
+ WHERE(GWORK1(:) .and. ABS(ZWORK1(:)) - .01 > 0.)
+ GWORK1(:) = .false.
+ PTIMEC(:) = 1.E-1
+ ZTPR(:) = 0.
+ ZWORK5(:) = 0.
+ ENDWHERE
+ do JK = IKB, IKE
+ PWSUB(:, JK) = PWSUB(:, JK) * ZWORK5(:)
+ ZPRLFLX(:, JK) = ZPRLFLX(:, JK) * ZWORK5(:)
+ ZPRSFLX(:, JK) = ZPRSFLX(:, JK) * ZWORK5(:)
+ enddo
+ GWORK4(:, 1:IKB) = .false.
+ GWORK4(:, IKE:IKS) = .false.
+!
+ ITSTEP(:) = INT(PTIMEC(:) / ZTIMEC(:)) + 1
+ ZTIMEC(:) = PTIMEC(:) / REAL(ITSTEP(:)) ! adjust fractional time step
+ ! to be an integer multiple of PTIMEC
+ ZTIMC(:, :) = SPREAD(ZTIMEC(:), DIM=2, NCOPIES=IKS)
+ ICOUNT(:) = 0
+!
+!
+!
+ KFTSTEPS = MAXVAL(ITSTEP(:))
+ do JSTEP = 1, KFTSTEPS ! Enter the fractional time step loop here
+!
+ ICOUNT(:) = ICOUNT(:) + 1
+!
+ GWORK3(:) = ITSTEP(:) >= ICOUNT(:) .and. GWORK1(:)
+!
+!
+!* 7. Assign enthalpy and r_w values at the top and bottom of each
+! layer based on the sign of w
+! ------------------------------------------------------------
+!
+ ZTHMFIN(:, :) = 0.
+ ZRWMFIN(:, :) = 0.
+ ZRCMFIN(:, :) = 0.
+ ZRIMFIN(:, :) = 0.
+ ZTHMFOUT(:, :) = 0.
+ ZRWMFOUT(:, :) = 0.
+ ZRCMFOUT(:, :) = 0.
+ ZRIMFOUT(:, :) = 0.
+!
+ do JK = IKB + 1, JKMAX
+ do JI = 1, IIE
+ GWORK4(JI, JK) = GWORK3(JI) .and. JK <= KCTL(JI)
+ enddo
+ JKP = MAX(IKB + 1, JK - 1)
+ do JI = 1, IIE
+ if(GWORK3(JI)) then
+!
+ ZWORK1(JI) = SIGN(1., ZOMG(JI, JK))
+ ZWORK2(JI) = 0.5 * (1.+ZWORK1(JI))
+ ZWORK1(JI) = 0.5 * (1.-ZWORK1(JI))
+ ZTHMFIN(JI, JK) = -ZOMG(JI, JK) * ZTHLC(JI, JKP) * ZWORK1(JI)
+ ZTHMFOUT(JI, JK) = ZOMG(JI, JK) * ZTHLC(JI, JK) * ZWORK2(JI)
+ ZRWMFIN(JI, JK) = -ZOMG(JI, JK) * PRWC(JI, JKP) * ZWORK1(JI)
+ ZRWMFOUT(JI, JK) = ZOMG(JI, JK) * PRWC(JI, JK) * ZWORK2(JI)
+ ZRCMFIN(JI, JK) = -ZOMG(JI, JK) * PRCC(JI, JKP) * ZWORK1(JI)
+ ZRCMFOUT(JI, JK) = ZOMG(JI, JK) * PRCC(JI, JK) * ZWORK2(JI)
+ ZRIMFIN(JI, JK) = -ZOMG(JI, JK) * PRIC(JI, JKP) * ZWORK1(JI)
+ ZRIMFOUT(JI, JK) = ZOMG(JI, JK) * PRIC(JI, JK) * ZWORK2(JI)
+ endif
+ enddo
+ do JI = 1, IIE
+ if(GWORK3(JI)) then
+ ZTHMFIN(JI, JKP) = ZTHMFIN(JI, JKP) + ZTHMFOUT(JI, JK) * ZWORK2(JI)
+ ZTHMFOUT(JI, JKP) = ZTHMFOUT(JI, JKP) + ZTHMFIN(JI, JK) * ZWORK1(JI)
+ ZRWMFIN(JI, JKP) = ZRWMFIN(JI, JKP) + ZRWMFOUT(JI, JK) * ZWORK2(JI)
+ ZRWMFOUT(JI, JKP) = ZRWMFOUT(JI, JKP) + ZRWMFIN(JI, JK) * ZWORK1(JI)
+ ZRCMFIN(JI, JKP) = ZRCMFIN(JI, JKP) + ZRCMFOUT(JI, JK) * ZWORK2(JI)
+ ZRCMFOUT(JI, JKP) = ZRCMFOUT(JI, JKP) + ZRCMFIN(JI, JK) * ZWORK1(JI)
+ ZRIMFIN(JI, JKP) = ZRIMFIN(JI, JKP) + ZRIMFOUT(JI, JK) * ZWORK2(JI)
+ ZRIMFOUT(JI, JKP) = ZRIMFOUT(JI, JKP) + ZRIMFIN(JI, JK) * ZWORK1(JI)
+!
+ endif
+ enddo
+ enddo
+!
+ WHERE(GWORK4(:, :))
+!
+!******************************************************************************
+!
+!* 8. Update the environmental values of enthalpy and r_w at each level
+! NOTA: These are the MAIN EQUATIONS of the scheme
+! -----------------------------------------------------------------
+!
+!
+ ZTHLC(:, :) = ZTHLC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZTHMFIN(:, :) + PUDR(:, :) * PUTHL(:, :) + &
+ PDDR(:, :) * PDTHL(:, :) - ZTHMFOUT(:, :) - &
+ (PUER(:, :) + PDER(:, :)) * PTHL(:, :))
+ PRWC(:, :) = PRWC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZRWMFIN(:, :) + PUDR(:, :) * PURW(:, :) + &
+ PDDR(:, :) * PDRW(:, :) - ZRWMFOUT(:, :) - &
+ (PUER(:, :) + PDER(:, :)) * PRW(:, :))
+ PRCC(:, :) = PRCC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZRCMFIN(:, :) + PUDR(:, :) * PURC(:, :) - ZRCMFOUT(:, :) - &
+ (PUER(:, :) + PDER(:, :)) * PRC(:, :))
+ PRIC(:, :) = PRIC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZRIMFIN(:, :) + PUDR(:, :) * PURI(:, :) - ZRIMFOUT(:, :) - &
+ (PUER(:, :) + PDER(:, :)) * PRI(:, :))
+!
+!
+!******************************************************************************
+!
+ ENDWHERE
+!
+ enddo ! Exit the fractional time step loop
+!
+!
+!* 9. Allow frozen precipitation to melt over a 200 mb deep layer
+! -----------------------------------------------------------
+!
+ do JK = JKMAX, IKB + 1, -1
+ ZTHLC(:, JK) = ZTHLC(:, JK) - &
+ ZPRMELT(:) * ZWORK6(:, JK) / MAX(XMELDPTH, ZMELDPTH(:))
+ enddo
+!
+!
+!* 10. Compute final linearized value of theta envir.
+! ----------------------------------------------
+!
+ do JK = IKB + 1, JKMAX
+ do JI = 1, IIE
+ if(GWORK1(JI) .and. JK <= KCTL(JI)) then
+ ZPI(JI) = (XP00 / PPRES(JI, JK))**ZRDOCP
+ ZCPH(JI) = XCPD + PRWC(JI, JK) * XCPV
+ ZWORK2(JI) = PTH(JI, JK) / ZPI(JI) ! first temperature estimate
+ ZLV(JI) = XLVTT + (XCPV - XCL) * (ZWORK2(JI) - XTT)
+ ZLS(JI) = XLVTT + (XCPV - XCI) * (ZWORK2(JI) - XTT)
+ ! final linearized temperature
+ ZWORK2(JI) = (ZTHLC(JI, JK) + ZLV(JI) * PRCC(JI, JK) + ZLS(JI) * PRIC(JI, JK) &
+ - (1.+PRWC(JI, JK)) * XG * PZ(JI, JK)) / ZCPH(JI)
+ ZWORK2(JI) = MAX(180., MIN(340., ZWORK2(JI)))
+ PTHC(JI, JK) = ZWORK2(JI) * ZPI(JI) ! final adjusted envir. theta
+ endif
+ enddo
+ enddo
+!
+!
+!* 11. Compute new cloud ( properties at new LCL )
+! NOTA: The computations are very close to
+! that in routine TRIGGER_FUNCT
+! ---------------------------------------------
+!
+ call CONVECT_CLOSURE_THRVLCL(KLON, KLEV, &
+ PPRES, PTHC, PRWC, PZ, GWORK1, &
+ ZTHLCL, ZRVLCL, ZZLCL, ZTLCL, ZTELCL, &
+ ILCL, KDPL, KPBL)
+!
+!
+ ZTLCL(:) = MAX(230., MIN(335., ZTLCL(:))) ! set some overflow bounds
+ ZTELCL(:) = MAX(230., MIN(335., ZTELCL(:)))
+ ZTHLCL(:) = MAX(230., MIN(345., ZTHLCL(:)))
+ ZRVLCL(:) = MAX(0., MIN(1., ZRVLCL(:)))
+!
+!
+!* 12. Compute adjusted CAPE
+! ---------------------
+!
+ ZCAPE(:) = 0.
+ ZPI(:) = ZTHLCL(:) / ZTLCL(:)
+ ZPI(:) = MAX(0.95, MIN(1.5, ZPI(:)))
+ ZWORK1(:) = XP00 / ZPI(:)**ZCPORD ! pressure at LCL
+!
+ call CONVECT_SATMIXRATIO(KLON, ZWORK1, ZTELCL, ZWORK3, ZLV, ZLS, ZCPH)
+ ZWORK3(:) = MIN(.1, MAX(0., ZWORK3(:)))
+!
+ ! compute theta_e updraft undilute
+ ZTHEUL(:) = ZTLCL(:) * ZPI(:)**(1.-0.28 * ZRVLCL(:)) &
+ * EXP((3374.6525 / ZTLCL(:) - 2.5403) &
+ * ZRVLCL(:) * (1.+0.81 * ZRVLCL(:)))
+!
+ ! compute theta_e saturated environment at LCL
+ ZTHES1(:) = ZTELCL(:) * ZPI(:)**(1.-0.28 * ZWORK3(:)) &
+ * EXP((3374.6525 / ZTELCL(:) - 2.5403) &
+ * ZWORK3(:) * (1.+0.81 * ZWORK3(:)))
+!
+ do JK = MINVAL(ILCL(:)), JKMAX
+ JKP = JK - 1
+ do JI = 1, IIE
+ ZWORK4(JI) = 1.
+ if(JK == ILCL(JI)) ZWORK4(JI) = 0.
+!
+ ! compute theta_e saturated environment and adjusted values
+ ! of theta
+!
+ GWORK3(JI) = JK >= ILCL(JI) .and. JK <= KCTL(JI) .and. GWORK1(JI)
+!
+ ZPI(JI) = (XP00 / PPRES(JI, JK))**ZRDOCP
+ ZWORK2(JI) = PTHC(JI, JK) / ZPI(JI)
+ enddo
+!
+ call CONVECT_SATMIXRATIO(KLON, PPRES(:, JK), ZWORK2, ZWORK3, ZLV, ZLS, ZCPH)
+!
+!
+ do JI = 1, IIE
+ if(GWORK3(JI)) then
+ ZTHES2(JI) = ZWORK2(JI) * ZPI(JI)**(1.-0.28 * ZWORK3(JI)) &
+ * EXP((3374.6525 / ZWORK2(JI) - 2.5403) &
+ * ZWORK3(JI) * (1.+0.81 * ZWORK3(JI)))
+!
+ ZWORK3(JI) = PZ(JI, JK) - PZ(JI, JKP) * ZWORK4(JI) - &
+ (1.-ZWORK4(JI)) * ZZLCL(JI) ! level thickness
+ ZWORK1(JI) = (2.*ZTHEUL(JI)) / (ZTHES1(JI) + ZTHES2(JI)) - 1.
+ ZCAPE(JI) = ZCAPE(JI) + XG * ZWORK3(JI) * MAX(0., ZWORK1(JI))
+ ZTHES1(JI) = ZTHES2(JI)
+ endif
+ enddo
+ enddo
+!
+!
+!* 13. Determine mass adjustment factor knowing how much
+! CAPE has been removed.
+! -------------------------------------------------
+!
+ WHERE(GWORK1(:))
+ ZWORK1(:) = MAX(PCAPE(:) - ZCAPE(:), 0.1 * PCAPE(:))
+ ZWORK2(:) = ZCAPE(:) / (PCAPE(:) + 1.E-8)
+!
+ GWORK1(:) = ZWORK2(:) > 0.1 .OR. ZCAPE(:) == 0. ! mask for adjustment
+ ENDWHERE
+!
+ WHERE(ZCAPE(:) == 0. .and. GWORK1(:)) ZADJ(:) = ZADJ(:) * 0.5
+ WHERE(ZCAPE(:) /= 0. .and. GWORK1(:)) &
+ ZADJ(:) = ZADJ(:) * XSTABC * PCAPE(:) / (ZWORK1(:) + 1.E-8)
+ ZADJ(:) = MIN(ZADJ(:), ZADJMAX(:))
+!
+!
+!* 13. Adjust mass flux by the factor ZADJ to converge to
+! specified degree of stabilization
+! ----------------------------------------------------
+!
+ call CONVECT_CLOSURE_ADJUST(KLON, KLEV, ZADJ, &
+ PUMF, ZUMF, PUER, ZUER, PUDR, ZUDR, &
+ PDMF, ZDMF, PDER, ZDER, PDDR, ZDDR, &
+ ZPRMELT, ZPRMELTO, PDTEVR, ZDTEVR, &
+ PTPR, ZTPR, &
+ PPRLFLX, ZPRLFLX, PPRSFLX, ZPRSFLX)
+!
+!
+ if(COUNT(GWORK1(:)) == 0) EXIT ! exit big adjustment iteration loop
+ ! when all columns have reached
+ ! desired degree of stabilization.
+!
+ enddo ! end of big adjustment iteration loop
+!
+!
+ ! skip adj. total water array to water vapor
+ do JK = IKB, IKE
+ PRWC(:, JK) = MAX(0., PRWC(:, JK) - PRCC(:, JK) - PRIC(:, JK))
+ enddo
+!
+ ! compute surface solid (ice) precipitation
+ PSPR(:) = ZPRMELT(:) * (1.-ZMELDPTH(:) / XMELDPTH)
+ PSPR(:) = MAX(0., PSPR(:))
+!
+!
+ENDsubroutine CONVECT_CLOSURE
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+! ######################
+MODULE MODI_DEEP_CONVECTION
+! ######################
+!
+ INTERFACE
+!
+ subroutine DEEP_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OREFRESH, ODOWN, OSETTADJ, &
+ PPABST, PZZ, PDXDY, PTIMEC, &
+ PTT, PRVT, PRCT, PRIT, PUT, PVT, PWT, &
+ KCOUNT, PTTEN, PRVTEN, PRCTEN, PRITEN, &
+ PPRLTEN, PPRSTEN, &
+ KCLTOP, KCLBAS, PPRLFLX, PPRSFLX, &
+ PUMF, PDMF, PCAPE, &
+ OCH1CONV, KCH1, PCH1, PCH1TEN)
+
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KIDIA ! value of the first point in x
+ INTEGER, INTENT(IN) :: KFDIA ! value of the last point in x
+ INTEGER, INTENT(IN) :: KBDIA ! vertical computations start at
+! ! KBDIA that is at least 1
+ INTEGER, INTENT(IN) :: KTDIA ! vertical computations can be
+ ! limited to KLEV + 1 - KTDIA
+ ! default=1
+ REAL, INTENT(IN) :: PDTCONV ! Interval of time between two
+ ! calls of the deep convection
+ ! scheme
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ LOGICAL, INTENT(IN) :: OREFRESH ! refresh or not tendencies
+ ! at every call
+ LOGICAL, INTENT(IN) :: ODOWN ! take or not convective
+ ! downdrafts into account
+ LOGICAL, INTENT(IN) :: OSETTADJ ! logical to set convective
+ ! adjustment time by user
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTT ! grid scale temperature at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRVT ! grid scale water vapor "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRCT ! grid scale r_c "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRIT ! grid scale r_i "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUT ! grid scale horiz. wind u "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PVT ! grid scale horiz. wind v "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PWT ! grid scale vertical
+ ! velocity (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPABST ! grid scale pressure at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! horizontal grid area (m -a2)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTIMEC ! value of convective adjustment
+ ! time if OSETTADJ=.true.
+!
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCOUNT ! convective counter (recompute
+ ! tendency or keep it)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PTTEN ! convective temperature
+ ! tendency (K/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRVTEN ! convective r_v tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRCTEN ! convective r_c tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRITEN ! convective r_i tendency (1/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRLTEN! liquid surf. precipitation
+ ! tendency (m/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRSTEN! solid surf. precipitation
+ ! tendency (m/s)
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLTOP ! cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLBAS ! cloud base level
+ ! they are given a value of
+ ! 0 if no convection
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PPRLFLX! liquid precip flux (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PPRSFLX! solid precip flux (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s m2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDMF ! downdraft mass flux (kg/s m2)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PCAPE ! maximum CAPE (J/kg)
+!
+ LOGICAL, INTENT(IN) :: OCH1CONV ! include tracer transport
+ INTEGER, INTENT(IN) :: KCH1 ! number of species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(IN) :: PCH1! grid scale chemical species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(INOUT):: PCH1TEN! species conv. tendency (1/s)
+ LOGICAL :: OUSECHEM ! flag for chemistry
+ LOGICAL :: OCH_CONV_SCAV ! & scavenging
+ LOGICAL :: OCH_CONV_LINOX ! & LiNOx
+ LOGICAL :: ODUST ! flag for dust
+ LOGICAL :: OSALT ! flag for sea salt
+ REAL, DIMENSION(KLON, KLEV) :: PRHODREF ! grid scale density
+ REAL, DIMENSION(KLON) :: PIC_RATE ! IC lightning frequency
+ REAL, DIMENSION(KLON) :: PCG_RATE ! CG lightning frequency
+
+!
+ ENDsubroutine DEEP_CONVECTION
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_DEEP_CONVECTION
+!
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/09/21 10:55:01
+!-----------------------------------------------------------------
+! ############################################################################
+subroutine DEEP_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OREFRESH, ODOWN, OSETTADJ, &
+ PPABST, PZZ, PDXDY, PTIMEC, &
+ PTT, PRVT, PRCT, PRIT, PUT, PVT, PWT, &
+ KCOUNT, PTTEN, PRVTEN, PRCTEN, PRITEN, &
+ PPRLTEN, PPRSTEN, &
+ KCLTOP, KCLBAS, PPRLFLX, PPRSFLX, &
+ PUMF, PDMF, PCAPE, &
+ OCH1CONV, KCH1, PCH1, PCH1TEN)
+! ############################################################################
+!
+!!**** Monitor routine to compute all convective tendencies by calls
+!! of several subroutines.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the convective
+!! tendencies. The routine first prepares all necessary grid-scale
+!! variables. The final convective tendencies are then computed by
+!! calls of different subroutines.
+!!
+!!
+!!** METHOD
+!! ------
+!! We start by selecting convective columns in the model domain through
+!! the call of routine TRIGGER_FUNCT. Then, we allocate memory for the
+!! convection updraft and downdraft variables and gather the grid scale
+!! variables in convective arrays.
+!! The updraft and downdraft computations are done level by level starting
+!! at the bottom and top of the domain, respectively.
+!! All computations are done on MNH thermodynamic levels. The depth
+!! of the current model layer k is defined by DP(k)=P(k-1)-P(k)
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! CONVECT_TRIGGER_FUNCT
+!! CONVECT_SATMIXRATIO
+!! CONVECT_UPDRAFT
+!! CONVECT_CONDENS
+!! CONVECT_MIXING_FUNCT
+!! CONVECT_TSTEP_PREF
+!! CONVECT_DOWNDRAFT
+!! CONVECT_PRECIP_ADJUST
+!! CONVECT_CLOSURE
+!! CONVECT_CLOSURE_THRVLCL
+!! CONVECT_CLOSURE_ADJUST
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XPI ! number Pi
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV ! specific heat for dry air and water vapor
+!! XRHOLW ! density of liquid water
+!! XALPW, XBETAW, XGAMW ! constants for water saturation pressure
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporization, sublimation heat constant
+!! XCL, XCI ! specific heat for liquid water and ice
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XCRAD ! cloud radius
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Bechtold, 1997 : Meso-NH scientific documentation (31 pp)
+!! Bechtold et al., 2001, Quart. J. Roy. Met. Soc.
+!! Kain and Fritsch, 1990, J. Atmos. Sci., Vol. 47, 2784-2801.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol. 24, 165-170.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Peter Bechtold 04/10/97 replace theta_il by enthalpy
+!! " 10/12/98 changes for ARPEGE
+!! " 12/12/00 add conservation correction
+!! C. Mari 13/02/01 add scavenging of chemical species in updraft
+!! P. Jabouille 02/07/01 case of lagragian variables
+!! P. Tulet 02/03/05 update for dust
+!! C.Lac 27/09/10 modification loop index for reproducibility
+!! Juan 24/09/2012: for BUG Pgi rewrite PACK function on mode_pack_pgi
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAREXT
+ USE MODD_CONVPAR
+!USE MODD_NSV, ONLY : NSV_LGBEG,NSV_LGEND, &
+! NSV_CHEMBEG,NSV_CHEMEND, &
+! NSV_LNOXBEG
+!USE MODD_CH_M9_n, ONLY : CNAMES
+!
+!USE MODI_CH_CONVECT_LINOX
+ USE MODI_CONVECT_TRIGGER_FUNCT
+ USE MODI_CONVECT_UPDRAFT
+ USE MODI_CONVECT_TSTEP_PREF
+ USE MODI_CONVECT_DOWNDRAFT
+ USE MODI_CONVECT_PRECIP_ADJUST
+ USE MODI_CONVECT_CLOSURE
+!USE MODI_CH_CONVECT_SCAVENGING
+!USE MODI_CONVECT_CHEM_TRANSPORT
+!
+!SeBi #ifdef MNH_PGI
+!SeBi USE MODE_PACK_PGI
+!SeBi #endif
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KIDIA ! value of the first point in x
+ INTEGER, INTENT(IN) :: KFDIA ! value of the last point in x
+ INTEGER, INTENT(IN) :: KBDIA ! vertical computations start at
+! ! KBDIA that is at least 1
+ INTEGER, INTENT(IN) :: KTDIA ! vertical computations can be
+ ! limited to KLEV + 1 - KTDIA
+ ! default=1
+ REAL, INTENT(IN) :: PDTCONV ! Interval of time between two
+ ! calls of the deep convection
+ ! scheme
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ LOGICAL, INTENT(IN) :: OREFRESH ! refresh or not tendencies
+ ! at every call
+ LOGICAL, INTENT(IN) :: ODOWN ! take or not convective
+ ! downdrafts into account
+ LOGICAL, INTENT(IN) :: OSETTADJ ! logical to set convective
+ ! adjustment time by user
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTT ! grid scale temperature at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRVT ! grid scale water vapor "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRCT ! grid scale r_c "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRIT ! grid scale r_i "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUT ! grid scale horiz. wind u "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PVT ! grid scale horiz. wind v "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PWT ! grid scale vertical
+ ! velocity (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPABST ! grid scale pressure at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! horizontal grid area (m -a2)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTIMEC ! value of convective adjustment
+ ! time if OSETTADJ=.true.
+!
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCOUNT ! convective counter (recompute
+ ! tendency or keep it)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PTTEN ! convective temperature
+ ! tendency (K/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRVTEN ! convective r_v tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRCTEN ! convective r_c tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRITEN ! convective r_i tendency (1/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRLTEN! liquid surf. precipitation
+ ! tendency (m/s)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PPRSTEN! solid surf. precipitation
+ ! tendency (m/s)
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLTOP ! cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLBAS ! cloud base level
+ ! they are given a value of
+ ! 0 if no convection
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PPRLFLX! liquid precip flux (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PPRSFLX! solid precip flux (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s m2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PDMF ! downdraft mass flux (kg/s m2)
+ REAL, DIMENSION(KLON), INTENT(INOUT):: PCAPE ! maximum CAPE (J/kg)
+!
+ LOGICAL, INTENT(IN) :: OCH1CONV ! include tracer transport
+ INTEGER, INTENT(IN) :: KCH1 ! number of species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(IN) :: PCH1! grid scale chemical species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(INOUT):: PCH1TEN! species conv. tendency (1/s)
+ LOGICAL :: OUSECHEM ! flag for chemistry
+ LOGICAL :: OCH_CONV_SCAV ! & scavenging
+ LOGICAL :: OCH_CONV_LINOX ! & LiNOx
+ LOGICAL :: ODUST ! flag for dust
+ LOGICAL :: OSALT ! flag for sea salt
+ REAL, DIMENSION(KLON, KLEV) :: PRHODREF ! grid scale density
+ REAL, DIMENSION(KLON) :: PIC_RATE ! IC lightning frequency
+ REAL, DIMENSION(KLON) :: PCG_RATE ! CG lightning frequency
+!
+!
+!* 0.2 Declarations of local fixed memory variables :
+!
+ INTEGER :: ITEST, ICONV, ICONV1 ! number of convective columns
+ INTEGER :: IIB, IIE ! horizontal loop bounds
+ INTEGER :: IKB, IKE ! vertical loop bounds
+ INTEGER :: IKS ! vertical dimension
+ INTEGER :: JI, JL, JJ ! horizontal loop index
+ INTEGER :: JN ! number of tracers
+ INTEGER :: JK, JKP, JKM ! vertical loop index
+ INTEGER :: IFTSTEPS ! only used for chemical tracers
+ real :: ZEPS, ZEPSA ! R_d / R_v, R_v / R_d
+ real :: ZRDOCP ! R_d/C_p
+!
+ LOGICAL, DIMENSION(KLON, KLEV) :: GTRIG3 ! 3D logical mask for convection
+ LOGICAL, DIMENSION(KLON) :: GTRIG ! 2D logical mask for trigger test
+ REAL, DIMENSION(KLON, KLEV) :: ZTHT, ZSTHV, ZSTHES ! grid scale theta,
+ ! theta_v, theta_es
+ REAL, DIMENSION(KLON) :: ZTIME ! convective time period
+ REAL, DIMENSION(KLON) :: ZWORK2, ZWORK2B ! work array
+ real :: ZW1 ! work variable
+!
+!
+!* 0.2 Declarations of local allocatable variables :
+!
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IDPL ! index for parcel departure level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IPBL ! index for source layer top
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ILCL ! index for lifting condensation level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IETL ! index for zero buoyancy level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ICTL ! index for cloud top level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ILFS ! index for level of free sink
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IDBL ! index for downdraft base level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IML ! melting level
+!
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ISDPL ! index for parcel departure level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ISPBL ! index for source layer top
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ISLCL ! index for lifting condensation level
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSTHLCL ! updraft theta at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSTLCL ! updraft temp. at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSRVLCL ! updraft rv at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSWLCL ! updraft w at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSZLCL ! LCL height
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSTHVELCL! envir. theta_v at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSDXDY ! grid area (m^2)
+!
+! grid scale variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZZ ! height of model layer (m)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZPRES ! grid scale pressure
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDPRES ! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZU ! grid scale horiz. u component on theta grid
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZV ! grid scale horiz. v component on theta grid
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZW ! grid scale vertical velocity on theta grid
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTT ! temperature
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTH ! grid scale theta
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHV ! grid scale theta_v
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHES, ZTHEST ! grid scale saturated theta_e
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRW ! grid scale total water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRV ! grid scale water vapor (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRC ! grid scale cloud water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRI ! grid scale cloud ice (kg/kg)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZDXDY ! grid area (m^2)
+!
+! updraft variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUPR ! updraft precipitation in
+ ! flux units (kg water / s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUTHV ! updraft theta_v (K)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUTT ! updraft temperature (K)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURI ! updraft cloud ice (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURR ! liquid precipit. (kg/kg)
+ ! produced in model layer
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURS ! solid precipit. (kg/kg)
+ ! produced in model layer
+ REAL, DIMENSION(:), ALLOCATABLE :: ZUTPR ! total updraft precipitation (kg/s)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZMFLCL ! cloud base unit mass flux(kg/s)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZCAPE ! available potent. energy
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTHLCL ! updraft theta at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTLCL ! updraft temp. at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZRVLCL ! updraft rv at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZWLCL ! updraft w at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZZLCL ! LCL height
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTHVELCL! envir. theta_v at LCL
+!
+! downdraft variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDDR ! downdraft detrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDTHL ! downdraft enthalpy (J/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDRW ! downdraft total water (kg/kg)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZMIXF ! mixed fraction at LFS
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTPR ! total surf precipitation (kg/s)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSPR ! solid surf precipitation (kg/s)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZDTEVR ! donwndraft evapor. (kg/s)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZPREF ! precipitation efficiency
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDTEVRF ! donwndraft evapor. (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZPRLFLX ! liquid precip flux
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZPRSFLX ! solid precip flux
+!
+! closure variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZLMASS ! mass of model layer (kg)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTIMEA ! advective time period
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTIMEC, ZTIMED! time during which convection is
+ ! active at grid point (as ZTIME)
+!
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHC ! conv. adj. grid scale theta
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRVC ! conv. adj. grid scale r_w
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRCC ! conv. adj. grid scale r_c
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRIC ! conv. adj. grid scale r_i
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZWSUB ! envir. compensating subsidence (Pa/s)
+!
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: GTRIG1 ! logical mask for convection
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: GWORK ! logical work array
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IINDEX, IJINDEX, IJSINDEX, IJPINDEX!hor.index
+ REAL, DIMENSION(:), ALLOCATABLE :: ZCPH ! specific heat C_ph
+ REAL, DIMENSION(:), ALLOCATABLE :: ZLV, ZLS! latent heat of vaporis., sublim.
+ real :: ZES ! saturation vapor mixng ratio
+!
+! Chemical Tracers:
+ REAL, DIMENSION(:, :, :), ALLOCATABLE:: ZCH1 ! grid scale chemical specy (kg/kg)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE:: ZCH1C ! conv. adjust. chemical specy 1
+ REAL, DIMENSION(:, :), ALLOCATABLE:: ZWORK3 ! work array
+ LOGICAL, DIMENSION(:, :, :), ALLOCATABLE::GTRIG4 ! logical mask
+ integer :: JN_NO ! index of NO compound in PCH1
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZWORK4, ZWORK4C
+ ! LiNOx conc. and tendency
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZZZ, ZRHODREF
+ REAL, DIMENSION(:), ALLOCATABLE :: ZIC_RATE, ZCG_RATE
+!
+!-------------------------------------------------------------------------------
+!
+!* SeBi set some logical to false and real to nul because unused here
+! -------------------------------------------------------------
+ OUSECHEM = .false.
+ OCH_CONV_SCAV = .false.
+ OCH_CONV_LINOX = .false.
+ ODUST = .false.
+ OSALT = .false.
+ PRHODREF = 0.0
+ PIC_RATE = 0.0
+ PCG_RATE = 0.0
+
+!
+!* 0.3 Compute loop bounds
+! -------------------
+!
+ IIB = KIDIA
+ IIE = KFDIA
+ JCVEXB = MAX(0, KBDIA - 1)
+ IKB = 1 + JCVEXB
+ IKS = KLEV
+ JCVEXT = MAX(0, KTDIA - 1)
+ IKE = IKS - JCVEXT
+!
+!
+!* 0.5 Update convective counter ( where KCOUNT > 0
+! convection is still active ).
+! ---------------------------------------------
+!
+ KCOUNT(IIB:IIE) = KCOUNT(IIB:IIE) - 1
+!
+ if(OREFRESH) then
+ KCOUNT(:) = 1
+ KCOUNT(IIB:IIE) = 0 ! refresh or not at every call
+ endif
+!
+ GTRIG(:) = KCOUNT(:) <= 0
+ ITEST = COUNT(GTRIG(:))
+ if(ITEST == 0) then ! if convection is already active at every grid point
+ RETURN
+ endif
+ ! exit DEEP_CONVECTION
+!
+!
+!* 0.7 Reset convective tendencies to zero if convective
+! counter becomes negative
+! -------------------------------------------------
+!
+ do JJ = 1, KLEV; do JI = 1, KLON
+ GTRIG3(JI, JJ) = GTRIG(JI)
+ ENDdo; ENDdo
+ WHERE(GTRIG3(:, :))
+ PTTEN(:, :) = 0.
+ PRVTEN(:, :) = 0.
+ PRCTEN(:, :) = 0.
+ PRITEN(:, :) = 0.
+ PPRLFLX(:, :) = 0.
+ PPRSFLX(:, :) = 0.
+! PUTEN(:,:) = 0.
+! PVTEN(:,:) = 0.
+ PUMF(:, :) = 0.
+ PDMF(:, :) = 0.
+ ENDWHERE
+ WHERE(GTRIG(:))
+ PPRLTEN(:) = 0.
+ PPRSTEN(:) = 0.
+ KCLTOP(:) = 0
+ KCLBAS(:) = 0
+ PCAPE(:) = 0.
+ ENDWHERE
+ ALLOCATE(GTRIG4(KLON, KLEV, KCH1))
+ do JK = 1, KCH1; do JJ = 1, KLEV; do JI = 1, KLON
+!GTRIG4(:,:,:) = SPREAD( GTRIG3(:,:), DIM=3, NCOPIES=KCH1 )
+ GTRIG4(JI, JJ, JK) = GTRIG3(JI, JJ)
+ ENDdo; ENDdo; enddo
+ WHERE(GTRIG4(:, :, :)) PCH1TEN(:, :, :) = 0.
+ DEALLOCATE(GTRIG4)
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Initialize local variables
+! ----------------------------
+!
+ ZEPS = XRD / XRV
+ ZEPSA = XRV / XRD
+ ZRDOCP = XRD / XCPD
+!
+!
+!* 1.1 Set up grid scale theta, theta_v, theta_es
+! ------------------------------------------
+!
+ ZTHT(:, :) = 300.
+ ZSTHV(:, :) = 300.
+ ZSTHES(:, :) = 400.
+ do JK = IKB, IKE
+ do JI = IIB, IIE
+ if(PPABST(JI, JK) > 40.E2) then
+ ZTHT(JI, JK) = PTT(JI, JK) * (XP00 / PPABST(JI, JK))**ZRDOCP
+ ZSTHV(JI, JK) = ZTHT(JI, JK) * (1.+ZEPSA * PRVT(JI, JK)) / &
+ (1.+PRVT(JI, JK) + PRCT(JI, JK) + PRIT(JI, JK))
+!
+ ! use conservative Bolton (1980) formula for theta_e
+ ! it is used to compute CAPE for undilute parcel ascent
+ ! For economical reasons we do not use routine CONVECT_SATMIXRATIO here
+!
+ ZES = EXP(XALPW - XBETAW / PTT(JI, JK) - XGAMW * LOG(PTT(JI, JK)))
+ ZES = ZEPS * ZES / (PPABST(JI, JK) - ZES)
+ ZSTHES(JI, JK) = PTT(JI, JK) * (ZTHT(JI, JK) / PTT(JI, JK))** &
+ (1.-0.28 * ZES) * EXP((3374.6525 / PTT(JI, JK) - 2.5403) &
+ * ZES * (1.+0.81 * ZES))
+ endif
+ enddo
+ enddo
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. Test for convective columns and determine properties at the LCL
+! --------------------------------------------------------------
+!
+!* 2.1 Allocate arrays depending on number of model columns that need
+! to be tested for convection (i.e. where no convection is present
+! at the moment.
+! --------------------------------------------------------------
+!
+ ALLOCATE(ZPRES(ITEST, IKS))
+ ALLOCATE(ZZ(ITEST, IKS))
+ ALLOCATE(ZW(ITEST, IKS))
+ ALLOCATE(ZTH(ITEST, IKS))
+ ALLOCATE(ZTHV(ITEST, IKS))
+ ALLOCATE(ZTHEST(ITEST, IKS))
+ ALLOCATE(ZRV(ITEST, IKS))
+ ALLOCATE(ZSTHLCL(ITEST))
+ ALLOCATE(ZSTLCL(ITEST))
+ ALLOCATE(ZSRVLCL(ITEST))
+ ALLOCATE(ZSWLCL(ITEST))
+ ALLOCATE(ZSZLCL(ITEST))
+ ALLOCATE(ZSTHVELCL(ITEST))
+ ALLOCATE(ISDPL(ITEST))
+ ALLOCATE(ISPBL(ITEST))
+ ALLOCATE(ISLCL(ITEST))
+ ALLOCATE(ZSDXDY(ITEST))
+ ALLOCATE(GTRIG1(ITEST))
+ ALLOCATE(ZCAPE(ITEST))
+ ALLOCATE(IINDEX(KLON))
+ ALLOCATE(IJSINDEX(ITEST))
+ do JI = 1, KLON
+ IINDEX(JI) = JI
+ enddo
+ IJSINDEX(:) = PACK(IINDEX(:), MASK=GTRIG(:))
+!
+ ZPRES = 0.
+ ZZ = 0.
+ ZTH = 0.
+ ZTHV = 0.
+ ZTHEST = 0.
+ ZRV = 0.
+ ZW = 0.
+!
+ do JK = IKB, IKE
+ do JI = 1, ITEST
+ JL = IJSINDEX(JI)
+ ZPRES(JI, JK) = PPABST(JL, JK)
+ ZZ(JI, JK) = PZZ(JL, JK)
+ ZTH(JI, JK) = ZTHT(JL, JK)
+ ZTHV(JI, JK) = ZSTHV(JL, JK)
+ ZTHEST(JI, JK) = ZSTHES(JL, JK)
+ ZRV(JI, JK) = MAX(0., PRVT(JL, JK))
+ ZW(JI, JK) = PWT(JL, JK)
+ enddo
+ enddo
+ do JI = 1, ITEST
+ JL = IJSINDEX(JI)
+ ZSDXDY(JI) = PDXDY(JL)
+ enddo
+!
+!* 2.2 Compute environm. enthalpy and total water = r_v + r_i + r_c
+! and envir. saturation theta_e
+! ------------------------------------------------------------
+!
+!
+!* 2.3 Test for convective columns and determine properties at the LCL
+! --------------------------------------------------------------
+!
+ ISLCL(:) = MAX(IKB, 2) ! initialize DPL PBL and LCL
+ ISDPL(:) = IKB
+ ISPBL(:) = IKB
+!
+!
+ call CONVECT_TRIGGER_FUNCT(ITEST, KLEV, &
+ ZPRES, ZTH, ZTHV, ZTHEST, &
+ ZRV, ZW, ZZ, ZSDXDY, &
+ ZSTHLCL, ZSTLCL, ZSRVLCL, ZSWLCL, ZSZLCL, &
+ ZSTHVELCL, ISLCL, ISDPL, ISPBL, GTRIG1, &
+ ZCAPE)
+!
+ do JI = 1, ITEST
+ JL = IJSINDEX(JI)
+ PCAPE(JL) = ZCAPE(JI)
+ enddo
+!
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZZ)
+ DEALLOCATE(ZTH)
+ DEALLOCATE(ZTHV)
+ DEALLOCATE(ZTHEST)
+ DEALLOCATE(ZRV)
+ DEALLOCATE(ZW)
+ DEALLOCATE(ZCAPE)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. After the call of TRIGGER_FUNCT we allocate all the dynamic
+! arrays used in the convection scheme using the mask GTRIG, i.e.
+! we do calculus only in convective columns. This corresponds to
+! a GATHER operation.
+! --------------------------------------------------------------
+!
+ ICONV = COUNT(GTRIG1(:))
+ if(ICONV == 0) then
+ DEALLOCATE(ZSTHLCL)
+ DEALLOCATE(ZSTLCL)
+ DEALLOCATE(ZSRVLCL)
+ DEALLOCATE(ZSWLCL)
+ DEALLOCATE(ZSZLCL)
+ DEALLOCATE(ZSTHVELCL)
+ DEALLOCATE(ZSDXDY)
+ DEALLOCATE(ISLCL)
+ DEALLOCATE(ISDPL)
+ DEALLOCATE(ISPBL)
+ DEALLOCATE(GTRIG1)
+ DEALLOCATE(IINDEX)
+ DEALLOCATE(IJSINDEX)
+ RETURN ! no convective column has been found, exit DEEP_CONVECTION
+ endif
+!
+ ! vertical index variables
+!
+ ALLOCATE(IDPL(ICONV))
+ ALLOCATE(IPBL(ICONV))
+ ALLOCATE(ILCL(ICONV))
+ ALLOCATE(ICTL(ICONV))
+ ALLOCATE(IETL(ICONV))
+!
+ ! grid scale variables
+!
+ ALLOCATE(ZZ(ICONV, IKS)); ZZ = 0.0
+ ALLOCATE(ZPRES(ICONV, IKS)); ZPRES = 0.0
+ ALLOCATE(ZDPRES(ICONV, IKS+1)); ZDPRES = 0.0
+ ALLOCATE(ZU(ICONV, IKS)); ZU = 0.0
+ ALLOCATE(ZV(ICONV, IKS)); ZV = 0.0
+ ALLOCATE(ZTT(ICONV, IKS)); ZTT = 0.0
+ ALLOCATE(ZTH(ICONV, IKS)); ZTH = 0.0
+ ALLOCATE(ZTHV(ICONV, IKS)); ZTHV = 0.0
+ ALLOCATE(ZTHL(ICONV, IKS)); ZTHL = 0.0
+ ALLOCATE(ZTHES(ICONV, IKS)); ZTHES = 0.0
+ ALLOCATE(ZRV(ICONV, IKS)); ZRV = 0.0
+ ALLOCATE(ZRC(ICONV, IKS)); ZRC = 0.0
+ ALLOCATE(ZRI(ICONV, IKS)); ZRI = 0.0
+ ALLOCATE(ZRW(ICONV, IKS)); ZRW = 0.0
+ ALLOCATE(ZDXDY(ICONV)); ZDXDY = 0.0
+!
+ ! updraft variables
+!
+ ALLOCATE(ZUMF(ICONV, IKS))
+ ALLOCATE(ZUER(ICONV, IKS))
+ ALLOCATE(ZUDR(ICONV, IKS))
+ ALLOCATE(ZUPR(ICONV, IKS))
+ ALLOCATE(ZUTHL(ICONV, IKS))
+ ALLOCATE(ZUTHV(ICONV, IKS))
+ ALLOCATE(ZUTT(ICONV, IKS))
+ ALLOCATE(ZURW(ICONV, IKS))
+ ALLOCATE(ZURC(ICONV, IKS))
+ ALLOCATE(ZURI(ICONV, IKS))
+ ALLOCATE(ZURR(ICONV, IKS))
+ ALLOCATE(ZURS(ICONV, IKS))
+ ALLOCATE(ZUTPR(ICONV))
+ ALLOCATE(ZTHLCL(ICONV))
+ ALLOCATE(ZTLCL(ICONV))
+ ALLOCATE(ZRVLCL(ICONV))
+ ALLOCATE(ZWLCL(ICONV))
+ ALLOCATE(ZMFLCL(ICONV))
+ ALLOCATE(ZZLCL(ICONV))
+ ALLOCATE(ZTHVELCL(ICONV))
+ ALLOCATE(ZCAPE(ICONV))
+!
+! work variables
+!
+ ALLOCATE(IJINDEX(ICONV))
+ ALLOCATE(IJPINDEX(ICONV))
+ ALLOCATE(ZCPH(ICONV))
+ ALLOCATE(ZLV(ICONV))
+ ALLOCATE(ZLS(ICONV))
+!
+!
+!* 3.1 Gather grid scale and updraft base variables in
+! arrays using mask GTRIG
+! ---------------------------------------------------
+!
+ GTRIG(:) = UNPACK(GTRIG1(:), MASK=GTRIG, FIELD=.false.)
+ IJINDEX(:) = PACK(IINDEX(:), MASK=GTRIG(:))
+!
+ do JK = IKB, IKE
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ ZZ(JI, JK) = PZZ(JL, JK)
+ ZPRES(JI, JK) = PPABST(JL, JK)
+ ZTT(JI, JK) = PTT(JL, JK)
+ ZTH(JI, JK) = ZTHT(JL, JK)
+ ZTHES(JI, JK) = ZSTHES(JL, JK)
+ ZRV(JI, JK) = MAX(0., PRVT(JL, JK))
+ ZRC(JI, JK) = MAX(0., PRCT(JL, JK))
+ ZRI(JI, JK) = MAX(0., PRIT(JL, JK))
+ ZTHV(JI, JK) = ZSTHV(JL, JK)
+ ZU(JI, JK) = PUT(JL, JK)
+ ZV(JI, JK) = PVT(JL, JK)
+ enddo
+ enddo
+ if(OSETTADJ) then
+ ALLOCATE(ZTIMED(ICONV))
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ ZTIMED(JI) = PTIMEC(JL)
+ enddo
+ endif
+!
+ do JI = 1, ITEST
+ IJSINDEX(JI) = JI
+ enddo
+ IJPINDEX(:) = PACK(IJSINDEX(:), MASK=GTRIG1(:))
+ do JI = 1, ICONV
+ JL = IJPINDEX(JI)
+ IDPL(JI) = ISDPL(JL)
+ IPBL(JI) = ISPBL(JL)
+ ILCL(JI) = ISLCL(JL)
+ ZTHLCL(JI) = ZSTHLCL(JL)
+ ZTLCL(JI) = ZSTLCL(JL)
+ ZRVLCL(JI) = ZSRVLCL(JL)
+ ZWLCL(JI) = ZSWLCL(JL)
+ ZZLCL(JI) = ZSZLCL(JL)
+ ZTHVELCL(JI) = ZSTHVELCL(JL)
+ ZDXDY(JI) = ZSDXDY(JL)
+ enddo
+ ALLOCATE(GWORK(ICONV))
+ GWORK(:) = PACK(GTRIG1(:), MASK=GTRIG1(:))
+ DEALLOCATE(GTRIG1)
+ ALLOCATE(GTRIG1(ICONV))
+ GTRIG1(:) = GWORK(:)
+!
+ DEALLOCATE(GWORK)
+ DEALLOCATE(IJPINDEX)
+ DEALLOCATE(ISDPL)
+ DEALLOCATE(ISPBL)
+ DEALLOCATE(ISLCL)
+ DEALLOCATE(ZSTHLCL)
+ DEALLOCATE(ZSTLCL)
+ DEALLOCATE(ZSRVLCL)
+ DEALLOCATE(ZSWLCL)
+ DEALLOCATE(ZSZLCL)
+ DEALLOCATE(ZSTHVELCL)
+ DEALLOCATE(ZSDXDY)
+!
+!
+!* 3.2 Compute pressure difference
+! ---------------------------------------------------
+!
+ ZDPRES(:, IKB) = 0.
+ do JK = IKB + 1, IKE
+ ZDPRES(:, JK) = ZPRES(:, JK - 1) - ZPRES(:, JK)
+ enddo
+!
+!* 3.3 Compute environm. enthalpy and total water = r_v + r_i + r_c
+! ----------------------------------------------------------
+!
+ do JK = IKB, IKE, 1
+ ZRW(:, JK) = ZRV(:, JK) + ZRC(:, JK) + ZRI(:, JK)
+ ZCPH(:) = XCPD + XCPV * ZRW(:, JK)
+ ZLV(:) = XLVTT + (XCPV - XCL) * (ZTT(:, JK) - XTT) ! compute L_v
+ ZLS(:) = XLSTT + (XCPV - XCI) * (ZTT(:, JK) - XTT) ! compute L_i
+ ZTHL(:, JK) = ZCPH(:) * ZTT(:, JK) + (1.+ZRW(:, JK)) * XG * ZZ(:, JK) &
+ - ZLV(:) * ZRC(:, JK) - ZLS(:) * ZRI(:, JK)
+ enddo
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. Compute updraft properties
+! ----------------------------
+!
+!* 4.1 Set mass flux at LCL ( here a unit mass flux with w = 1 m/s )
+! -------------------------------------------------------------
+!
+ do JI = 1, ICONV
+ JK = ILCL(JI) - 1
+ ZMFLCL(JI) = ZPRES(JI, JK) / (XRD * ZTT(JI, JK) * &
+ (1.+ZEPS * ZRVLCL(JI))) * XPI * XCRAD * XCRAD &
+ * MAX(1., ZDXDY(JI) / XA25)
+ enddo
+!
+ DEALLOCATE(ZCPH)
+ DEALLOCATE(ZLV)
+ DEALLOCATE(ZLS)
+!
+!
+ call CONVECT_UPDRAFT(ICONV, KLEV, &
+ KICE, ZPRES, ZDPRES, ZZ, ZTHL, ZTHV, ZTHES, ZRW, &
+ ZTHLCL, ZTLCL, ZRVLCL, ZWLCL, ZZLCL, ZTHVELCL, &
+ ZMFLCL, GTRIG1, ILCL, IDPL, IPBL, &
+ ZUMF, ZUER, ZUDR, ZUTHL, ZUTHV, ZURW, &
+ ZURC, ZURI, ZURR, ZURS, ZUPR, &
+ ZUTPR, ZCAPE, ICTL, IETL, ZUTT)
+!
+!
+!
+!* 4.2 In routine UPDRAFT GTRIG1 has been set to false when cloud
+! thickness is smaller than 3 km
+! -----------------------------------------------------------
+!
+!
+ ICONV1 = COUNT(GTRIG1)
+!
+ if(ICONV1 > 0) then
+!
+!* 4.3 Allocate memory for downdraft variables
+! ---------------------------------------
+!
+! downdraft variables
+!
+ ALLOCATE(ILFS(ICONV))
+ ALLOCATE(IDBL(ICONV))
+ ALLOCATE(IML(ICONV))
+ ALLOCATE(ZDMF(ICONV, IKS))
+ ALLOCATE(ZDER(ICONV, IKS))
+ ALLOCATE(ZDDR(ICONV, IKS))
+ ALLOCATE(ZDTHL(ICONV, IKS))
+ ALLOCATE(ZDRW(ICONV, IKS))
+ ALLOCATE(ZLMASS(ICONV, IKS)); ZLMASS = 0.0
+ do JK = IKB, IKE
+ ZLMASS(:, JK) = ZDXDY(:) * ZDPRES(:, JK) / XG ! mass of model layer
+ enddo
+ ZLMASS(:, IKB) = ZLMASS(:, IKB + 1)
+ ALLOCATE(ZMIXF(ICONV))
+ ALLOCATE(ZTPR(ICONV))
+ ALLOCATE(ZSPR(ICONV))
+ ALLOCATE(ZDTEVR(ICONV))
+ ALLOCATE(ZPREF(ICONV))
+ ALLOCATE(ZDTEVRF(ICONV, IKS))
+ ALLOCATE(ZPRLFLX(ICONV, IKS))
+ ALLOCATE(ZPRSFLX(ICONV, IKS))
+!
+! closure variables
+!
+ ALLOCATE(ZTIMEA(ICONV))
+ ALLOCATE(ZTIMEC(ICONV))
+ ALLOCATE(ZTHC(ICONV, IKS))
+ ALLOCATE(ZRVC(ICONV, IKS))
+ ALLOCATE(ZRCC(ICONV, IKS))
+ ALLOCATE(ZRIC(ICONV, IKS))
+ ALLOCATE(ZWSUB(ICONV, IKS))
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. Compute downdraft properties
+! ----------------------------
+!
+!* 5.1 Compute advective time period and precipitation
+! efficiency as a function of mean ambient wind (shear)
+! --------------------------------------------------------
+!
+ call CONVECT_TSTEP_PREF(ICONV, KLEV, &
+ ZU, ZV, ZPRES, ZZ, ZDXDY, ILCL, ICTL, &
+ ZTIMEA, ZPREF)
+!
+ ! exclude convective downdrafts if desired
+ if(.not. ODOWN) ZPREF(:) = 1.
+!
+! Compute the period during which convection is active
+ ZTIMEC(:) = MAX(1800., MIN(3600., ZTIMEA(:)))
+ ZTIMEC(:) = REAL(INT(ZTIMEC(:) / PDTCONV)) * PDTCONV
+ ZTIMEC(:) = MAX(PDTCONV, ZTIMEC(:)) ! necessary if PDTCONV > 1800
+ if(OSETTADJ) then
+ ZTIMEC(:) = MAX(PDTCONV, ZTIMED(:))
+ endif
+!
+!
+!* 5.2 Compute melting level
+! ----------------------
+!
+ IML(:) = IKB
+ do JK = IKE, IKB, -1
+ WHERE(ZTT(:, JK) <= XTT) IML(:) = JK
+ enddo
+!
+ call CONVECT_DOWNDRAFT(ICONV, KLEV, &
+ KICE, ZPRES, ZDPRES, ZZ, ZTH, ZTHES, &
+ ZRW, ZRC, ZRI, &
+ ZPREF, ILCL, ICTL, IETL, &
+ ZUTHL, ZURW, ZURC, ZURI, &
+ ZDMF, ZDER, ZDDR, ZDTHL, ZDRW, &
+ ZMIXF, ZDTEVR, ILFS, IDBL, IML, &
+ ZDTEVRF)
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. Adjust up and downdraft mass flux to be consistent
+! with precipitation efficiency relation.
+! ---------------------------------------------------
+!
+ call CONVECT_PRECIP_ADJUST(ICONV, KLEV, &
+ ZPRES, ZUMF, ZUER, ZUDR, ZUPR, ZUTPR, ZURW, &
+ ZDMF, ZDER, ZDDR, ZDTHL, ZDRW, &
+ ZPREF, ZTPR, ZMIXF, ZDTEVR, &
+ ILFS, IDBL, ILCL, ICTL, IETL, &
+ ZDTEVRF)
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. Determine adjusted environmental values assuming
+! that all available buoyant energy must be removed
+! within an advective time step ZTIMEC.
+! ---------------------------------------------------
+!
+ call CONVECT_CLOSURE(ICONV, KLEV, &
+ ZPRES, ZDPRES, ZZ, ZDXDY, ZLMASS, &
+ ZTHL, ZTH, ZRW, ZRC, ZRI, GTRIG1, &
+ ZTHC, ZRVC, ZRCC, ZRIC, ZWSUB, &
+ ILCL, IDPL, IPBL, ILFS, ICTL, IML, &
+ ZUMF, ZUER, ZUDR, ZUTHL, ZURW, &
+ ZURC, ZURI, ZUPR, &
+ ZDMF, ZDER, ZDDR, ZDTHL, ZDRW, &
+ ZTPR, ZSPR, ZDTEVR, &
+ ZCAPE, ZTIMEC, &
+ IFTSTEPS, &
+ ZDTEVRF, ZPRLFLX, ZPRSFLX)
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. Determine the final grid-scale (environmental) convective
+! tendencies and set convective counter
+! --------------------------------------------------------
+!
+!
+!* 8.1 Grid scale tendencies
+! ---------------------
+!
+! in order to save memory, the tendencies are temporarily stored
+! in the tables for the adjusted grid-scale values
+!
+ do JK = IKB, IKE
+ ZTHC(:, JK) = (ZTHC(:, JK) - ZTH(:, JK)) / ZTIMEC(:) &
+ * (ZPRES(:, JK) / XP00)**ZRDOCP ! change theta in temperature
+ ZRVC(:, JK) = (ZRVC(:, JK) - ZRW(:, JK) + ZRC(:, JK) + ZRI(:, JK)) / ZTIMEC(:)
+ ZRCC(:, JK) = (ZRCC(:, JK) - ZRC(:, JK)) / ZTIMEC(:)
+ ZRIC(:, JK) = (ZRIC(:, JK) - ZRI(:, JK)) / ZTIMEC(:)
+!
+ ZPRLFLX(:, JK) = ZPRLFLX(:, JK) / (XRHOLW * ZDXDY(:))
+ ZPRSFLX(:, JK) = ZPRSFLX(:, JK) / (XRHOLW * ZDXDY(:))
+!
+ enddo
+!
+ ZPRLFLX(:, IKB) = ZPRLFLX(:, IKB + 1)
+ ZPRSFLX(:, IKB) = ZPRSFLX(:, IKB + 1)
+!
+!
+!* 8.2 Apply conservation correction
+! -----------------------------
+!
+ ! Compute vertical integrals
+!
+! Reproducibility
+! JKM = MAXVAL( ICTL(:) )
+ JKM = IKE - 1
+ ZWORK2(:) = 0.
+ ZWORK2B(:) = 0.
+ do JK = IKB + 1, JKM
+ JKP = JK + 1
+ do JI = 1, ICONV
+ ZW1 = .5 * (ZPRES(JI, JK - 1) - ZPRES(JI, JKP)) / XG
+ ZWORK2(JI) = ZWORK2(JI) + (ZRVC(JI, JK) + ZRCC(JI, JK) + ZRIC(JI, JK)) * ZW1 ! moisture
+ ZWORK2B(JI) = ZWORK2B(JI) + ((XCPD + XCPV * ZRW(JI, JK)) * ZTHC(JI, JK) - &
+ (XLVTT + (XCPV - XCL) * (ZTT(JI, JK) - XTT)) * ZRCC(JI, JK) - &
+ (XLSTT + (XCPV - XCL) * (ZTT(JI, JK) - XTT)) * ZRIC(JI, JK)) * &
+ ZW1 ! enthalpy
+ enddo
+ enddo
+!
+ ! Budget error (compare integral to surface precip.)
+!
+ do JI = 1, ICONV
+ if(ZTPR(JI) > 0.) then
+ ZW1 = XG / (ZPRES(JI, IKB) - ZPRES(JI, JKP) - .5 * ( &
+ ZDPRES(JI, IKB + 1) - ZDPRES(JI, JKP + 1)))
+ ZWORK2(JI) = (ZTPR(JI) / ZDXDY(JI) + ZWORK2(JI)) * ZW1
+ ZWORK2B(JI) = (ZTPR(JI) / ZDXDY(JI) * &
+ (XLVTT + (XCPV - XCL) * (ZTT(JI, IKB) - XTT)) - ZWORK2B(JI)) &
+ * ZW1
+ endif
+ enddo
+!
+ ! Apply uniform correction
+!
+ do JK = JKM, IKB + 1, -1
+ do JI = 1, ICONV
+ if(ZTPR(JI) > 0. .and. JK <= ICTL(JI)) then
+ ! ZW1 = ABS(ZRVC(JI,JK)) + ABS(ZRCC(JI,JK)) + ABS(ZRIC(JI,JK)) + 1.E-12
+ ! ZRVC(JI,JK) = ZRVC(JI,JK) - ABS(ZRVC(JI,JK))/ZW1*ZWORK2(JI) ! moisture
+ ZRVC(JI, JK) = ZRVC(JI, JK) - ZWORK2(JI) ! moisture
+ ! ZRCC(JI,JK) = ZRCC(JI,JK) - ABS(ZRCC(JI,JK))/ZW1*ZWORK2(JI)
+ ! ZRIC(JI,JK) = ZRIC(JI,JK) - ABS(ZRIC(JI,JK))/ZW1*ZWORK2(JI)
+ ZTHC(JI, JK) = ZTHC(JI, JK) + ZWORK2B(JI) / (XCPD + XCPV * ZRW(JI, JK))! energy
+ endif
+ enddo
+ enddo
+!
+!
+! execute a "scatter"= pack command to store the tendencies in
+! the final 2D tables
+!
+ do JK = IKB, IKE
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ PTTEN(JL, JK) = ZTHC(JI, JK)
+ PRVTEN(JL, JK) = ZRVC(JI, JK)
+ PRCTEN(JL, JK) = ZRCC(JI, JK)
+ PRITEN(JL, JK) = ZRIC(JI, JK)
+!
+ PPRLFLX(JL, JK) = ZPRLFLX(JI, JK)
+ PPRSFLX(JL, JK) = ZPRSFLX(JI, JK)
+ enddo
+ enddo
+!
+!
+!* 8.3 Convective rainfall tendency
+! ----------------------------
+!
+ ! liquid and solid surface rainfall tendency in m/s
+ ZTPR(:) = ZTPR(:) / (XRHOLW * ZDXDY(:)) ! total surf precip
+ ZSPR(:) = ZSPR(:) / (XRHOLW * ZDXDY(:)) ! solid surf precip
+ ZTPR(:) = ZTPR(:) - ZSPR(:) ! compute liquid part
+!
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ PPRLTEN(JL) = ZTPR(JI)
+ PPRSTEN(JL) = ZSPR(JI)
+ enddo
+!
+!
+! Cloud base and top levels
+! -------------------------
+!
+ ILCL(:) = MIN(ILCL(:), ICTL(:))
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ KCLTOP(JL) = ICTL(JI)
+ KCLBAS(JL) = ILCL(JI)
+ enddo
+!
+!
+!* 8.4 Set convective counter
+! ----------------------
+!
+ ! compute convective counter for just activated convective
+ ! grid points
+ ! If the advective time period is less than specified
+ ! minimum for convective period, allow feedback to occur only
+ ! during advective time
+!
+ ZTIME(:) = 1.
+ ZWORK2(:) = 0.
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ ZTIME(JL) = ZTIMEC(JI)
+ ZWORK2(JL) = ZTIMEA(JI)
+ ZWORK2(JL) = MIN(ZWORK2(JL), ZTIME(JL))
+ ZWORK2(JL) = MAX(ZWORK2(JL), PDTCONV)
+ if(GTRIG(JL)) KCOUNT(JL) = INT(ZWORK2(JL) / PDTCONV)
+ if(GTRIG(JL) .and. PPRLTEN(JL) < 1.E-14) KCOUNT(JL) = 0
+ enddo
+!
+!
+!* 8.7 Compute convective tendencies for Tracers
+! ------------------------------------------
+!
+! if ( OCH1CONV ) then
+!!
+! ALLOCATE( ZCH1(ICONV,IKS,KCH1) ) ; ZCH1 = 0.0
+! ALLOCATE( ZCH1C(ICONV,IKS,KCH1) ) ; ZCH1C = 0.0
+! ALLOCATE( ZWORK3(ICONV,KCH1) )
+!!
+! ALLOCATE( ZRHODREF(ICONV,IKS) )
+! ZRHODREF=0.
+! if ( OCH_CONV_LINOX ) then
+! ALLOCATE( ZZZ(ICONV,IKS) )
+! ALLOCATE( ZIC_RATE(ICONV) )
+! ALLOCATE( ZCG_RATE(ICONV) )
+! ALLOCATE( ZWORK4(ICONV,IKS) )
+! ALLOCATE( ZWORK4C(ICONV,IKS) )
+! ZZZ=0.
+! ZIC_RATE=0.
+! ZCG_RATE=0.
+! ZWORK4=0.
+! ZWORK4C=0.
+! end if
+!!
+! do JI = 1, ICONV
+! do JK = IKB, IKE
+! JL = IJINDEX(JI)
+! ZCH1(JI,JK,:) = PCH1(JL,JK,:)
+! ZRHODREF(JI,JK)=PRHODREF(JL,JK)
+! end do
+! ZRHODREF(JI,1) = PRHODREF(JL,IKB)
+! ZRHODREF(JI,IKS) = PRHODREF(JL,IKE)
+! end do
+! ZCH1(:,1,:) = ZCH1(:,IKB,:)
+! ZCH1(:,IKS,:) = ZCH1(:,IKE,:)
+!!
+! JN_NO = 0
+! if ( OCH_CONV_LINOX ) then
+! do JK = IKB, IKE
+! do JI = 1, ICONV
+! JL = IJINDEX(JI)
+! ZZZ(JI,JK)=PZZ(JL,JK)
+! ZIC_RATE(JI)=PIC_RATE(JL)
+! ZCG_RATE(JI)=PCG_RATE(JL)
+! end do
+! end do
+! if (OUSECHEM) then
+! do JN = NSV_CHEMBEG,NSV_CHEMEND
+! if (CNAMES(JN-NSV_CHEMBEG+1)=='NO') JN_NO = JN
+! end do
+! else
+! JN_NO = NSV_LNOXBEG
+! end if
+! ZWORK4(:,:) = ZCH1(:,:,JN_NO)
+! call CH_CONVECT_LINOX( ICONV, KLEV, ZWORK4, ZWORK4C, &
+! IDPL, IPBL, ILCL, ICTL, ILFS, IDBL, &
+! ZUMF, ZUER, ZUDR, ZDMF, ZDER, ZDDR, &
+! ZTIMEC, ZDXDY, ZMIXF, ZLMASS, ZWSUB, &
+! IFTSTEPS, ZUTT, ZRHODREF, &
+! OUSECHEM, ZZZ, ZIC_RATE, ZCG_RATE )
+! do JI = 1, ICONV
+! JL = IJINDEX(JI)
+! PIC_RATE(JL)=ZIC_RATE(JI)
+! PCG_RATE(JL)=ZCG_RATE(JI)
+! end do
+! end if
+!!
+! if ((OUSECHEM .and. OCH_CONV_SCAV).OR.(ODUST .and. OCH_CONV_SCAV).OR.&
+! (OSALT .and. OCH_CONV_SCAV) ) then
+!!
+! call CH_CONVECT_SCAVENGING( ICONV, KLEV, KCH1, ZCH1, ZCH1C, &
+! IDPL, IPBL, ILCL, ICTL, ILFS, IDBL, &
+! ZUMF, ZUER, ZUDR, ZDMF, ZDER, ZDDR, &
+! ZTIMEC, ZDXDY, ZMIXF, ZLMASS, ZWSUB, &
+! IFTSTEPS, &
+! ZURC, ZURR, ZURI, ZURS, ZUTT, ZPRES, &
+! ZRHODREF, PPABST, ZTHT )
+!!
+! if (OCH_CONV_LINOX) then
+! ZCH1C(:,:,JN_NO) = ZWORK4C(:,:)
+! end if
+!! no conservation correction for scavenging
+! do JI = 1, ICONV
+! JL = IJINDEX(JI)
+! if ( ZTPR(JI) > 0. ) then
+! do JK = IKB, IKE
+! PCH1TEN(JL,JK,:) = (ZCH1C(JI,JK,:)- ZCH1(JI,JK,:)) /ZTIMEC(JI)
+! end do
+! else
+! do JK = IKB, IKE
+! PCH1TEN(JL,JK,:) = 0.
+! end do
+! end if
+! end do
+!
+!!
+! else
+!!
+! call CONVECT_CHEM_TRANSPORT( ICONV, KLEV, KCH1, ZCH1, ZCH1C, &
+! IDPL, IPBL, ILCL, ICTL, ILFS, IDBL, &
+! ZUMF, ZUER, ZUDR, ZDMF, ZDER, ZDDR, &
+! ZTIMEC, ZDXDY, ZMIXF, ZLMASS, ZWSUB, &
+! IFTSTEPS )
+!!
+! if (OCH_CONV_LINOX) then
+! ZCH1C(:,:,JN_NO) = ZWORK4C(:,:)
+! end if
+!!
+!!* 8.8 Apply conservation correction
+!! -----------------------------
+!!
+! ! Compute vertical integrals
+!!
+!! Reproducibility
+!! JKM = MAXVAL( ICTL(:) )
+! JKM = IKE - 1
+! do JN = 1, KCH1
+! if((JN < NSV_LGBEG .OR. JN>NSV_LGEND-1) .and. JN .NE. JN_NO ) then
+! ! no correction for Lagrangian and LiNOx variables
+! ZWORK3(:,JN) = 0.
+! ZWORK2(:) = 0.
+! do JK = IKB+1, JKM
+! JKP = JK + 1
+! do JI = 1, ICONV
+! ZW1 = .5 * (ZPRES(JI,JK-1) - ZPRES(JI,JKP))
+! ZWORK3(JI,JN) = ZWORK3(JI,JN) + (ZCH1C(JI,JK,JN)-ZCH1(JI,JK,JN)) * ZW1
+! ZWORK2(JI) = ZWORK2(JI) + ABS(ZCH1C(JI,JK,JN)) * ZW1
+! end do
+! end do
+!!
+! ! Apply concentration weighted correction
+!!
+! do JK = JKM, IKB+1, -1
+! do JI = 1, ICONV
+! if ( ZTPR(JI) > 0. .and. JK <= ICTL(JI) ) then
+! ZCH1C(JI,JK,JN) = ZCH1C(JI,JK,JN) - &
+! ZWORK3(JI,JN)*ABS(ZCH1C(JI,JK,JN))/MAX(1.E-30,ZWORK2(JI))
+! ! ZCH1C(JI,JK,JN) = MAX( ZCH1C(JI,JK,JN), -ZCH1(JI,JK,JN)/ZTIMEC(JI) )
+! end if
+! end do
+! end do
+! end if
+!!
+! do JI = 1, ICONV
+! JL = IJINDEX(JI)
+! if ( ZTPR(JI) > 0. ) then
+! do JK = IKB, IKE
+! PCH1TEN(JL,JK,JN) = (ZCH1C(JI,JK,JN)-ZCH1(JI,JK,JN) ) /ZTIMEC(JI)
+! end do
+! else
+! do JK = IKB, IKE
+! PCH1TEN(JL,JK,JN) = 0.
+! end do
+! end if
+! end do
+! end do
+! end if
+! end if
+!
+!-------------------------------------------------------------------------------
+!
+!* 9. Write up- and downdraft mass fluxes
+! ------------------------------------
+!
+ do JK = IKB, IKE
+ ZUMF(:, JK) = ZUMF(:, JK) / ZDXDY(:) ! Mass flux per unit area
+ ZDMF(:, JK) = ZDMF(:, JK) / ZDXDY(:)
+ enddo
+ ZWORK2(:) = 1.
+ WHERE(PPRLTEN(:) < 1.E-14) ZWORK2(:) = 0.
+ do JK = IKB, IKE
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ PUMF(JL, JK) = ZUMF(JI, JK) * ZWORK2(JL)
+ PDMF(JL, JK) = ZDMF(JI, JK) * ZWORK2(JL)
+ enddo
+ enddo
+!
+!-------------------------------------------------------------------------------
+!
+!* 10. Deallocate all local arrays
+! ---------------------------
+!
+! downdraft variables
+!
+ DEALLOCATE(ZDMF)
+ DEALLOCATE(ZDER)
+ DEALLOCATE(ZDDR)
+ DEALLOCATE(ZDTHL)
+ DEALLOCATE(ZDRW)
+ DEALLOCATE(ZLMASS)
+ DEALLOCATE(ZMIXF)
+ DEALLOCATE(ZTPR)
+ DEALLOCATE(ZSPR)
+ DEALLOCATE(ZDTEVR)
+ DEALLOCATE(ZPREF)
+ DEALLOCATE(IML)
+ DEALLOCATE(ILFS)
+ DEALLOCATE(IDBL)
+ DEALLOCATE(ZDTEVRF)
+ DEALLOCATE(ZPRLFLX)
+ DEALLOCATE(ZPRSFLX)
+!
+! closure variables
+!
+ DEALLOCATE(ZTIMEA)
+ DEALLOCATE(ZTIMEC)
+ DEALLOCATE(ZTHC)
+ DEALLOCATE(ZRVC)
+ DEALLOCATE(ZRCC)
+ DEALLOCATE(ZRIC)
+ DEALLOCATE(ZWSUB)
+!
+ if(OCH1CONV) then
+ DEALLOCATE(ZCH1)
+ DEALLOCATE(ZCH1C)
+ DEALLOCATE(ZWORK3)
+ DEALLOCATE(ZRHODREF)
+ if(OCH_CONV_LINOX) then
+ DEALLOCATE(ZZZ)
+ DEALLOCATE(ZIC_RATE)
+ DEALLOCATE(ZCG_RATE)
+ DEALLOCATE(ZWORK4)
+ DEALLOCATE(ZWORK4C)
+ endif
+ endif
+!
+ endif
+!
+! vertical index
+!
+ DEALLOCATE(IDPL)
+ DEALLOCATE(IPBL)
+ DEALLOCATE(ILCL)
+ DEALLOCATE(ICTL)
+ DEALLOCATE(IETL)
+!
+! grid scale variables
+!
+ DEALLOCATE(ZZ)
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZDPRES)
+ DEALLOCATE(ZU)
+ DEALLOCATE(ZV)
+ DEALLOCATE(ZTT)
+ DEALLOCATE(ZTH)
+ DEALLOCATE(ZTHV)
+ DEALLOCATE(ZTHL)
+ DEALLOCATE(ZTHES)
+ DEALLOCATE(ZRW)
+ DEALLOCATE(ZRV)
+ DEALLOCATE(ZRC)
+ DEALLOCATE(ZRI)
+ DEALLOCATE(ZDXDY)
+!
+! updraft variables
+!
+ DEALLOCATE(ZUMF)
+ DEALLOCATE(ZUER)
+ DEALLOCATE(ZUDR)
+ DEALLOCATE(ZUTHL)
+ DEALLOCATE(ZUTHV)
+ DEALLOCATE(ZUTT)
+ DEALLOCATE(ZURW)
+ DEALLOCATE(ZURC)
+ DEALLOCATE(ZURI)
+ DEALLOCATE(ZURR)
+ DEALLOCATE(ZURS)
+ DEALLOCATE(ZUPR)
+ DEALLOCATE(ZUTPR)
+ DEALLOCATE(ZTHLCL)
+ DEALLOCATE(ZTLCL)
+ DEALLOCATE(ZRVLCL)
+ DEALLOCATE(ZWLCL)
+ DEALLOCATE(ZZLCL)
+ DEALLOCATE(ZTHVELCL)
+ DEALLOCATE(ZMFLCL)
+ DEALLOCATE(ZCAPE)
+ if(OSETTADJ) DEALLOCATE(ZTIMED)
+!
+! work arrays
+!
+ DEALLOCATE(IINDEX)
+ DEALLOCATE(IJINDEX)
+ DEALLOCATE(IJSINDEX)
+ DEALLOCATE(GTRIG1)
+!
+!
+ENDsubroutine DEEP_CONVECTION
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 modd 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ######spl
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_CLOSURE_ADJUST_SHAL
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_CLOSURE_ADJUST_SHAL(KLON, KLEV, PADJ, &
+ PUMF, PZUMF, PUER, PZUER, PUDR, PZUDR)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON), INTENT(IN) :: PADJ ! mass adjustment factor
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUMF ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUER ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUDR ! initial value of "
+!
+ ENDsubroutine CONVECT_CLOSURE_ADJUST_SHAL
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_CLOSURE_ADJUST_SHAL
+! ################################################################################
+subroutine CONVECT_CLOSURE_ADJUST_SHAL(KLON, KLEV, PADJ, &
+ PUMF, PZUMF, PUER, PZUER, PUDR, PZUDR)
+! ################################################################################
+!
+!!**** Uses closure adjustment factor to adjust mass flux and to modify
+!! precipitation efficiency when necessary. The computations are
+!! similar to routine CONVECT_PRECIP_ADJUST.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to adjust the mass flux using the
+!! factor PADJ computed in CONVECT_CLOSURE
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_CLOSURE_ADJUST)
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Last modified 15/11/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CONVPAREXT
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ REAL, DIMENSION(KLON), INTENT(IN) :: PADJ ! mass adjustment factor
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUMF ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUER ! initial value of "
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT) :: PZUDR ! initial value of "
+!
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IKB, IKE ! vert. loop bounds
+ INTEGER :: JK ! vertical loop index
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.3 Compute loop bounds
+! -------------------
+!
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Adjust mass flux by the factor PADJ to converge to
+! specified degree of stabilization
+! ----------------------------------------------------
+!
+ do JK = IKB + 1, IKE
+ PUMF(:, JK) = PZUMF(:, JK) * PADJ(:)
+ PUER(:, JK) = PZUER(:, JK) * PADJ(:)
+ PUDR(:, JK) = PZUDR(:, JK) * PADJ(:)
+ enddo
+!
+ENDsubroutine CONVECT_CLOSURE_ADJUST_SHAL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_CLOSURE_SHAL
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_CLOSURE_SHAL(KLON, KLEV, &
+ PPRES, PDPRES, PZ, PDXDY, PLMASS, &
+ PTHL, PTH, PRW, PRC, PRI, OTRIG1, &
+ PTHC, PRWC, PRCC, PRIC, PWSUB, &
+ KLCL, KDPL, KPBL, KCTL, &
+ PUMF, PUER, PUDR, PUTHL, PURW, &
+ PURC, PURI, PCAPE, PTIMEC, KFTSTEPS)
+
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! index lifting condens. level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! index for cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! index for departure level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! index for top of source layer
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PTIMEC ! convection time step
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m^2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OTRIG1 ! logical to keep trace of
+ ! convective arrays modified in UPDRAFT
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES ! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PLMASS ! mass of model layer (kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PCAPE ! available potent. energy
+ INTEGER, INTENT(OUT) :: KFTSTEPS! maximum of fract time steps
+ ! only used for chemical tracers
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURI ! updraft cloud ice (kg/kg)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PTHC ! conv. adj. grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRWC ! conv. adj. grid scale r_w
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRCC ! conv. adj. grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRIC ! conv. adj. grid scale r_i
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PWSUB ! envir. compensating subsidence(Pa/s)
+!
+ ENDsubroutine CONVECT_CLOSURE_SHAL
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_CLOSURE_SHAL
+! ##############################################################################
+subroutine CONVECT_CLOSURE_SHAL(KLON, KLEV, &
+ PPRES, PDPRES, PZ, PDXDY, PLMASS, &
+ PTHL, PTH, PRW, PRC, PRI, OTRIG1, &
+ PTHC, PRWC, PRCC, PRIC, PWSUB, &
+ KLCL, KDPL, KPBL, KCTL, &
+ PUMF, PUER, PUDR, PUTHL, PURW, &
+ PURC, PURI, PCAPE, PTIMEC, KFTSTEPS)
+! ##############################################################################
+!
+!!**** Uses modified Fritsch-Chappell closure
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the final adjusted
+!! (over a time step PTIMEC) environmental values of THETA_l, R_w, R_c, R_i
+!! The final convective tendencies can then be evaluated in the main
+!! routine DEEP_CONVECT by (PTHC-PTH)/PTIMEC
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! CONVECT_CLOSURE_THRVLCL
+!! CONVECT_CLOSURE_ADJUST_SHAL
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV ! specific heat for dry air and water vapor
+!! XCL, XCI ! specific heat for liquid water and ice
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporization, sublimation heat constant
+!!
+!! Module MODD_CONVPAR_SHAL
+!! XA25 ! reference grid area
+!! XSTABT ! stability factor in time integration
+!! XSTABC ! stability factor in CAPE adjustment
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_CLOSURE)
+!! Fritsch and Chappell, 1980, J. Atmos. Sci.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Peter Bechtold 15/11/96 change for enthalpie, r_c + r_i tendencies
+!! Tony Dore 14/10/96 Initialise local variables
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR_SHAL
+ USE MODD_CONVPAREXT
+!
+ USE MODI_CONVECT_CLOSURE_THRVLCL
+ USE MODI_CONVECT_SATMIXRATIO
+ USE MODI_CONVECT_CLOSURE_ADJUST_SHAL
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! index lifting condens. level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KCTL ! index for cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! index for departure level
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! index for top of source layer
+ REAL, DIMENSION(KLON), INTENT(INOUT) :: PTIMEC ! convection time step
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area (m^2)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH ! grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRC ! grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRI ! grid scale r_i
+ LOGICAL, DIMENSION(KLON), INTENT(IN) :: OTRIG1 ! logical to keep trace of
+ ! convective arrays modified in UPDRAFT
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES ! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PLMASS ! mass of model layer (kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PCAPE ! available potent. energy
+ INTEGER, INTENT(OUT) :: KFTSTEPS! maximum of fract time steps
+ ! only used for chemical tracers
+!
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PURI ! updraft cloud ice (kg/kg)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PTHC ! conv. adj. grid scale theta
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRWC ! conv. adj. grid scale r_w
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRCC ! conv. adj. grid scale r_c
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PRIC ! conv. adj. grid scale r_i
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT) :: PWSUB ! envir. compensating subsidence(Pa/s)
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ INTEGER :: IKS ! vertical dimension
+ INTEGER :: JK, JKP, JKMAX ! vertical loop index
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: JITER ! iteration loop index
+ INTEGER :: JSTEP ! fractional time loop index
+ real :: ZCPORD, ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON, KLEV) :: ZTHLC ! convectively adjusted
+ ! grid scale enthalpy
+ REAL, DIMENSION(KLON, KLEV) :: ZOMG ! conv. environm. subsidence (Pa/s)
+ REAL, DIMENSION(KLON, KLEV) :: ZUMF ! non-adjusted updraft mass flux
+ REAL, DIMENSION(KLON, KLEV) :: ZUER ! " updraft entrainm. rate
+ REAL, DIMENSION(KLON, KLEV) :: ZUDR ! " updraft detrainm. rate
+ REAL, DIMENSION(KLON) :: ZADJ ! mass adjustment factor
+ REAL, DIMENSION(KLON) :: ZADJMAX ! limit value for ZADJ
+ REAL, DIMENSION(KLON) :: ZCAPE ! new CAPE after adjustment
+ REAL, DIMENSION(KLON) :: ZTIMEC ! fractional convective time step
+ REAL, DIMENSION(KLON, KLEV):: ZTIMC ! 2D work array for ZTIMEC
+!
+ REAL, DIMENSION(KLON) :: ZTHLCL ! new theta at LCL
+ REAL, DIMENSION(KLON) :: ZRVLCL ! new r_v at LCL
+ REAL, DIMENSION(KLON) :: ZZLCL ! height of LCL
+ REAL, DIMENSION(KLON) :: ZTLCL ! temperature at LCL
+ REAL, DIMENSION(KLON) :: ZTELCL ! envir. temper. at LCL
+ REAL, DIMENSION(KLON) :: ZTHEUL ! theta_e for undilute ascent
+ REAL, DIMENSION(KLON) :: ZTHES1, ZTHES2! saturation environm. theta_e
+ REAL, DIMENSION(KLON, KLEV) :: ZTHMFIN, ZTHMFOUT, ZRWMFIN, ZRWMFOUT
+ REAL, DIMENSION(KLON, KLEV) :: ZRCMFIN, ZRCMFOUT, ZRIMFIN, ZRIMFOUT
+ ! work arrays for environm. compensat. mass flux
+ REAL, DIMENSION(KLON) :: ZPI ! (P/P00)**R_d/C_pd
+ REAL, DIMENSION(KLON) :: ZLV ! latent heat of vaporisation
+ REAL, DIMENSION(KLON) :: ZLS ! latent heat of sublimation
+ REAL, DIMENSION(KLON) :: ZCPH ! specific heat C_ph
+ INTEGER, DIMENSION(KLON) :: ITSTEP ! fractional convective time step
+ INTEGER, DIMENSION(KLON) :: ICOUNT ! timestep counter
+ INTEGER, DIMENSION(KLON) :: ILCL ! index lifting condens. level
+ INTEGER, DIMENSION(KLON) :: IWORK1 ! work array
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, ZWORK4, ZWORK5
+ LOGICAL, DIMENSION(KLON) :: GWORK1, GWORK3! work arrays
+ LOGICAL, DIMENSION(KLON, KLEV) :: GWORK4 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.2 Initialize local variables
+! ----------------------------
+!
+!
+ ZTIMC(:, :) = 0.
+ ZTHES2(:) = 0.
+ ZWORK1(:) = 0.
+ ZWORK2(:) = 0.
+ ZWORK3(:) = 0.
+ ZWORK4(:) = 0.
+ ZWORK5(:) = 0.
+ GWORK1(:) = .false.
+ GWORK3(:) = .false.
+ GWORK4(:, :) = .false.
+ ILCL(:) = KLCL(:)
+!
+ ZCPORD = XCPD / XRD
+ ZRDOCP = XRD / XCPD
+!
+ ZADJ(:) = 1.
+ ZWORK5(:) = 1.
+ WHERE(.not. OTRIG1(:)) ZWORK5(:) = 0.
+!
+!
+!* 0.3 Compute loop bounds
+! -------------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKS = KLEV
+ IKE = KLEV - JCVEXT
+ JKMAX = MAXVAL(KCTL(:))
+!
+!
+!* 2. Save initial mass flux values to be used in adjustment procedure
+! ---------------------------------------------------------------
+!
+ ZUMF(:, :) = PUMF(:, :)
+ ZUER(:, :) = PUER(:, :)
+ ZUDR(:, :) = PUDR(:, :)
+ ZOMG(:, :) = 0.
+ PWSUB(:, :) = 0.
+!
+!
+!* 3. Compute limits on the closure adjustment factor so that the
+! inflow in convective drafts from a given layer can't be larger
+! than the mass contained in this layer initially.
+! ---------------------------------------------------------------
+!
+ ZADJMAX(:) = 1000.
+ IWORK1(:) = ILCL(:)
+ JKP = MINVAL(KDPL(:))
+ do JK = JKP, IKE
+ do JI = 1, IIE
+ if(JK > KDPL(JI) .and. JK <= IWORK1(JI)) then
+ ZWORK1(JI) = PLMASS(JI, JK) / ((PUER(JI, JK) + 1.E-5) * PTIMEC(JI))
+ ZADJMAX(JI) = MIN(ZADJMAX(JI), ZWORK1(JI))
+ endif
+ enddo
+ enddo
+!
+!
+ GWORK1(:) = OTRIG1(:) ! logical array to limit adjustment to not definitively
+ ! adjusted columns
+!
+ do JK = IKB, IKE
+ ZTHLC(:, JK) = PTHL(:, JK) ! initialize adjusted envir. values
+ PRWC(:, JK) = PRW(:, JK)
+ PRCC(:, JK) = PRC(:, JK)
+ PRIC(:, JK) = PRI(:, JK)
+ PTHC(:, JK) = PTH(:, JK)
+ enddo
+!
+!
+!
+ do JITER = 1, 4 ! Enter adjustment loop to assure that all CAPE is
+ ! removed within the advective time interval TIMEC
+!
+ ZTIMEC(:) = PTIMEC(:)
+ GWORK4(:, :) = SPREAD(GWORK1(:), DIM=2, NCOPIES=IKS)
+ WHERE(GWORK4(:, :)) PWSUB(:, :) = 0.
+ ZOMG(:, :) = 0.
+!
+ do JK = IKB + 1, JKMAX
+ JKP = MAX(IKB + 1, JK - 1)
+ WHERE(GWORK1(:) .and. JK <= KCTL(:))
+!
+!
+!* 4. Determine vertical velocity at top and bottom of each layer
+! to satisfy mass continuity.
+! ---------------------------------------------------------------
+ ! we compute here Domega/Dp = - g rho Dw/Dz = 1/Dt
+!
+ ZWORK1(:) = -(PUER(:, JKP) - PUDR(:, JKP)) / PLMASS(:, JKP)
+!
+ PWSUB(:, JK) = PWSUB(:, JKP) - PDPRES(:, JK - 1) * ZWORK1(:)
+ ! we use PDPRES(JK-1) and not JKP in order to have zero subsidence
+ ! at the first layer
+!
+!
+!* 5. Compute fractional time step. For stability or
+! mass conservation reasons one must split full time step PTIMEC)
+! ---------------------------------------------------------------
+!
+ ZWORK1(:) = XSTABT * PDPRES(:, JKP) / (ABS(PWSUB(:, JK)) + 1.E-10)
+ ! the factor XSTABT is used for stability reasons
+ ZTIMEC(:) = MIN(ZTIMEC(:), ZWORK1(:))
+!
+ ! transform vertical velocity in mass flux units
+ ZOMG(:, JK) = PWSUB(:, JK) * PDXDY(:) / XG
+ ENDWHERE
+ enddo
+!
+!
+ WHERE(GWORK4(:, :))
+ ZTHLC(:, :) = PTHL(:, :) ! reinitialize adjusted envir. values
+ PRWC(:, :) = PRW(:, :) ! when iteration criterium not attained
+ PRCC(:, :) = PRC(:, :)
+ PRIC(:, :) = PRI(:, :)
+ PTHC(:, :) = PTH(:, :)
+ ENDWHERE
+!
+!
+! 6. Check for mass conservation, i.e. ZWORK1 > 1.E-2
+! If mass is not conserved, the convective tendencies
+! automatically become zero.
+! ----------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KCTL(JI)
+ ZWORK1(JI) = PUDR(JI, JK) * PDPRES(JI, JK) / (PLMASS(JI, JK) + .1) &
+ - PWSUB(JI, JK)
+ enddo
+ WHERE(GWORK1(:) .and. ABS(ZWORK1(:)) - .01 > 0.)
+ GWORK1(:) = .false.
+ PTIMEC(:) = 1.E-1
+ ZWORK5(:) = 0.
+ ENDWHERE
+ do JK = IKB, IKE
+ PWSUB(:, JK) = PWSUB(:, JK) * ZWORK5(:)
+ enddo
+ GWORK4(:, 1:IKB) = .false.
+ GWORK4(:, IKE:IKS) = .false.
+!
+ ITSTEP(:) = INT(PTIMEC(:) / ZTIMEC(:)) + 1
+ ZTIMEC(:) = PTIMEC(:) / REAL(ITSTEP(:)) ! adjust fractional time step
+ ! to be an integer multiple of PTIMEC
+ ZTIMC(:, :) = SPREAD(ZTIMEC(:), DIM=2, NCOPIES=IKS)
+ ICOUNT(:) = 0
+!
+!
+!
+ KFTSTEPS = MAXVAL(ITSTEP(:))
+ do JSTEP = 1, KFTSTEPS ! Enter the fractional time step loop here
+!
+ ICOUNT(:) = ICOUNT(:) + 1
+!
+ GWORK3(:) = ITSTEP(:) >= ICOUNT(:) .and. GWORK1(:)
+!
+!
+!* 7. Assign enthalpy and r_w values at the top and bottom of each
+! layer based on the sign of w
+! ------------------------------------------------------------
+!
+ ZTHMFIN(:, :) = 0.
+ ZRWMFIN(:, :) = 0.
+ ZRCMFIN(:, :) = 0.
+ ZRIMFIN(:, :) = 0.
+ ZTHMFOUT(:, :) = 0.
+ ZRWMFOUT(:, :) = 0.
+ ZRCMFOUT(:, :) = 0.
+ ZRIMFOUT(:, :) = 0.
+!
+ do JK = IKB + 1, JKMAX
+ do JI = 1, IIE
+ GWORK4(JI, JK) = GWORK3(JI) .and. JK <= KCTL(JI)
+ enddo
+ JKP = MAX(IKB + 1, JK - 1)
+ do JI = 1, IIE
+ if(GWORK3(JI)) then
+!
+ ZWORK1(JI) = SIGN(1., ZOMG(JI, JK))
+ ZWORK2(JI) = 0.5 * (1.+ZWORK1(JI))
+ ZWORK1(JI) = 0.5 * (1.-ZWORK1(JI))
+ ZTHMFIN(JI, JK) = -ZOMG(JI, JK) * ZTHLC(JI, JKP) * ZWORK1(JI)
+ ZTHMFOUT(JI, JK) = ZOMG(JI, JK) * ZTHLC(JI, JK) * ZWORK2(JI)
+ ZRWMFIN(JI, JK) = -ZOMG(JI, JK) * PRWC(JI, JKP) * ZWORK1(JI)
+ ZRWMFOUT(JI, JK) = ZOMG(JI, JK) * PRWC(JI, JK) * ZWORK2(JI)
+ ZRCMFIN(JI, JK) = -ZOMG(JI, JK) * PRCC(JI, JKP) * ZWORK1(JI)
+ ZRCMFOUT(JI, JK) = ZOMG(JI, JK) * PRCC(JI, JK) * ZWORK2(JI)
+ ZRIMFIN(JI, JK) = -ZOMG(JI, JK) * PRIC(JI, JKP) * ZWORK1(JI)
+ ZRIMFOUT(JI, JK) = ZOMG(JI, JK) * PRIC(JI, JK) * ZWORK2(JI)
+ endif
+ enddo
+ do JI = 1, IIE
+ if(GWORK3(JI)) then
+ ZTHMFIN(JI, JKP) = ZTHMFIN(JI, JKP) + ZTHMFOUT(JI, JK) * ZWORK2(JI)
+ ZTHMFOUT(JI, JKP) = ZTHMFOUT(JI, JKP) + ZTHMFIN(JI, JK) * ZWORK1(JI)
+ ZRWMFIN(JI, JKP) = ZRWMFIN(JI, JKP) + ZRWMFOUT(JI, JK) * ZWORK2(JI)
+ ZRWMFOUT(JI, JKP) = ZRWMFOUT(JI, JKP) + ZRWMFIN(JI, JK) * ZWORK1(JI)
+ ZRCMFIN(JI, JKP) = ZRCMFIN(JI, JKP) + ZRCMFOUT(JI, JK) * ZWORK2(JI)
+ ZRCMFOUT(JI, JKP) = ZRCMFOUT(JI, JKP) + ZRCMFIN(JI, JK) * ZWORK1(JI)
+ ZRIMFIN(JI, JKP) = ZRIMFIN(JI, JKP) + ZRIMFOUT(JI, JK) * ZWORK2(JI)
+ ZRIMFOUT(JI, JKP) = ZRIMFOUT(JI, JKP) + ZRIMFIN(JI, JK) * ZWORK1(JI)
+!
+ endif
+ enddo
+ enddo
+!
+ WHERE(GWORK4(:, :))
+!
+!******************************************************************************
+!
+!* 8. Update the environmental values of enthalpy and r_w at each level
+! NOTA: These are the MAIN EQUATIONS of the scheme
+! -----------------------------------------------------------------
+!
+!
+ ZTHLC(:, :) = ZTHLC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZTHMFIN(:, :) + PUDR(:, :) * PUTHL(:, :) &
+ - ZTHMFOUT(:, :) - PUER(:, :) * PTHL(:, :))
+ PRWC(:, :) = PRWC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZRWMFIN(:, :) + PUDR(:, :) * PURW(:, :) &
+ - ZRWMFOUT(:, :) - PUER(:, :) * PRW(:, :))
+ PRCC(:, :) = PRCC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZRCMFIN(:, :) + PUDR(:, :) * PURC(:, :) - ZRCMFOUT(:, :) - &
+ PUER(:, :) * PRC(:, :))
+ PRIC(:, :) = PRIC(:, :) + ZTIMC(:, :) / PLMASS(:, :) * ( &
+ ZRIMFIN(:, :) + PUDR(:, :) * PURI(:, :) - ZRIMFOUT(:, :) - &
+ PUER(:, :) * PRI(:, :))
+!
+!
+!******************************************************************************
+!
+ ENDWHERE
+!
+ enddo ! Exit the fractional time step loop
+!
+!
+!* 10. Compute final linearized value of theta envir.
+! ----------------------------------------------
+!
+ do JK = IKB + 1, JKMAX
+ do JI = 1, IIE
+ if(GWORK1(JI) .and. JK <= KCTL(JI)) then
+ ZPI(JI) = (XP00 / PPRES(JI, JK))**ZRDOCP
+ ZCPH(JI) = XCPD + PRWC(JI, JK) * XCPV
+ ZWORK2(JI) = PTH(JI, JK) / ZPI(JI) ! first temperature estimate
+ ZLV(JI) = XLVTT + (XCPV - XCL) * (ZWORK2(JI) - XTT)
+ ZLS(JI) = XLVTT + (XCPV - XCI) * (ZWORK2(JI) - XTT)
+ ! final linearized temperature
+ ZWORK2(JI) = (ZTHLC(JI, JK) + ZLV(JI) * PRCC(JI, JK) + ZLS(JI) * PRIC(JI, JK) &
+ - (1.+PRWC(JI, JK)) * XG * PZ(JI, JK)) / ZCPH(JI)
+ ZWORK2(JI) = MAX(180., MIN(340., ZWORK2(JI)))
+ PTHC(JI, JK) = ZWORK2(JI) * ZPI(JI) ! final adjusted envir. theta
+ endif
+ enddo
+ enddo
+!
+!
+!* 11. Compute new cloud ( properties at new LCL )
+! NOTA: The computations are very close to
+! that in routine TRIGGER_FUNCT
+! ---------------------------------------------
+!
+ call CONVECT_CLOSURE_THRVLCL(KLON, KLEV, &
+ PPRES, PTHC, PRWC, PZ, GWORK1, &
+ ZTHLCL, ZRVLCL, ZZLCL, ZTLCL, ZTELCL, &
+ ILCL, KDPL, KPBL)
+!
+!
+ ZTLCL(:) = MAX(230., MIN(335., ZTLCL(:))) ! set some overflow bounds
+ ZTELCL(:) = MAX(230., MIN(335., ZTELCL(:)))
+ ZTHLCL(:) = MAX(230., MIN(345., ZTHLCL(:)))
+ ZRVLCL(:) = MAX(0., MIN(1., ZRVLCL(:)))
+!
+!
+!* 12. Compute adjusted CAPE
+! ---------------------
+!
+ ZCAPE(:) = 0.
+ ZPI(:) = ZTHLCL(:) / ZTLCL(:)
+ ZPI(:) = MAX(0.95, MIN(1.5, ZPI(:)))
+ ZWORK1(:) = XP00 / ZPI(:)**ZCPORD ! pressure at LCL
+!
+ call CONVECT_SATMIXRATIO(KLON, ZWORK1, ZTELCL, ZWORK3, ZLV, ZLS, ZCPH)
+ ZWORK3(:) = MIN(.1, MAX(0., ZWORK3(:)))
+!
+ ! compute theta_e updraft undilute
+ ZTHEUL(:) = ZTLCL(:) * ZPI(:)**(1.-0.28 * ZRVLCL(:)) &
+ * EXP((3374.6525 / ZTLCL(:) - 2.5403) &
+ * ZRVLCL(:) * (1.+0.81 * ZRVLCL(:)))
+!
+ ! compute theta_e saturated environment at LCL
+ ZTHES1(:) = ZTELCL(:) * ZPI(:)**(1.-0.28 * ZWORK3(:)) &
+ * EXP((3374.6525 / ZTELCL(:) - 2.5403) &
+ * ZWORK3(:) * (1.+0.81 * ZWORK3(:)))
+!
+ do JK = MINVAL(ILCL(:)), JKMAX
+ JKP = JK - 1
+ do JI = 1, IIE
+ ZWORK4(JI) = 1.
+ if(JK == ILCL(JI)) ZWORK4(JI) = 0.
+!
+ ! compute theta_e saturated environment and adjusted values
+ ! of theta
+!
+ GWORK3(JI) = JK >= ILCL(JI) .and. JK <= KCTL(JI) .and. GWORK1(JI)
+!
+ ZPI(JI) = (XP00 / PPRES(JI, JK))**ZRDOCP
+ ZWORK2(JI) = PTHC(JI, JK) / ZPI(JI)
+ enddo
+!
+ call CONVECT_SATMIXRATIO(KLON, PPRES(:, JK), ZWORK2, ZWORK3, ZLV, ZLS, ZCPH)
+!
+!
+ do JI = 1, IIE
+ if(GWORK3(JI)) then
+ ZTHES2(JI) = ZWORK2(JI) * ZPI(JI)**(1.-0.28 * ZWORK3(JI)) &
+ * EXP((3374.6525 / ZWORK2(JI) - 2.5403) &
+ * ZWORK3(JI) * (1.+0.81 * ZWORK3(JI)))
+!
+ ZWORK3(JI) = PZ(JI, JK) - PZ(JI, JKP) * ZWORK4(JI) - &
+ (1.-ZWORK4(JI)) * ZZLCL(JI) ! level thickness
+ ZWORK1(JI) = (2.*ZTHEUL(JI)) / (ZTHES1(JI) + ZTHES2(JI)) - 1.
+ ZCAPE(JI) = ZCAPE(JI) + XG * ZWORK3(JI) * MAX(0., ZWORK1(JI))
+ ZTHES1(JI) = ZTHES2(JI)
+ endif
+ enddo
+ enddo
+!
+!
+!* 13. Determine mass adjustment factor knowing how much
+! CAPE has been removed.
+! -------------------------------------------------
+!
+ WHERE(GWORK1(:))
+ ZWORK1(:) = MAX(PCAPE(:) - ZCAPE(:), 0.2 * PCAPE(:))
+ ZWORK2(:) = ZCAPE(:) / (PCAPE(:) + 1.E-8)
+!
+ GWORK1(:) = ZWORK2(:) > 0.2 .OR. ZCAPE(:) == 0. ! mask for adjustment
+ ENDWHERE
+!
+ WHERE(ZCAPE(:) == 0. .and. GWORK1(:)) ZADJ(:) = ZADJ(:) * 0.5
+ WHERE(ZCAPE(:) /= 0. .and. GWORK1(:)) &
+ ZADJ(:) = ZADJ(:) * XSTABC * PCAPE(:) / (ZWORK1(:) + 1.E-8)
+ ZADJ(:) = MIN(ZADJ(:), ZADJMAX(:))
+!
+!
+!* 13. Adjust mass flux by the factor ZADJ to converge to
+! specified degree of stabilization
+! ----------------------------------------------------
+!
+ call CONVECT_CLOSURE_ADJUST_SHAL(KLON, KLEV, ZADJ, &
+ PUMF, ZUMF, PUER, ZUER, PUDR, ZUDR)
+!
+!
+ if(COUNT(GWORK1(:)) == 0) EXIT ! exit big adjustment iteration loop
+ ! when all columns have reached
+ ! desired degree of stabilization.
+!
+ enddo ! end of big adjustment iteration loop
+!
+!
+ ! skip adj. total water array to water vapor
+ do JK = IKB, IKE
+ PRWC(:, JK) = MAX(0., PRWC(:, JK) - PRCC(:, JK) - PRIC(:, JK))
+ enddo
+!
+!
+ENDsubroutine CONVECT_CLOSURE_SHAL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_TRIGGER_SHAL
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_TRIGGER_SHAL(KLON, KLEV, &
+ PPRES, PTH, PTHV, PTHES, &
+ PRV, PW, PZ, PDXDY, PTKECLS, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, &
+ PTHVELCL, KLCL, KDPL, KPBL, OTRIG)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ INTEGER, INTENT(IN) :: KLEV ! vertical loop index
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTKECLS ! TKE CLS
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH, PTHV ! theta, theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! envir. satur. theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! vapor mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of grid point (m)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PW ! vertical velocity
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PWLCL ! parcel velocity at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(OUT):: OTRIG ! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KPBL ! contains index of source layer top
+!
+ ENDsubroutine CONVECT_TRIGGER_SHAL
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_TRIGGER_SHAL
+! ########################################################################
+subroutine CONVECT_TRIGGER_SHAL(KLON, KLEV, &
+ PPRES, PTH, PTHV, PTHES, &
+ PRV, PW, PZ, PDXDY, PTKECLS, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, &
+ PTHVELCL, KLCL, KDPL, KPBL, OTRIG)
+! ########################################################################
+!
+!!**** Determine convective columns as well as the cloudy values of theta,
+!! and qv at the lifting condensation level (LCL)
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine convective columns
+!!
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!! What we look for is the undermost unstable level at each grid point.
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Routine CONVECT_SATMIXRATIO
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! Reference pressure
+!! XRD, XRV ! Gaz constants for dry air and water vapor
+!! XCPD ! Cpd (dry air)
+!! XTT ! triple point temperature
+!! XBETAW, XGAMW ! constants for vapor saturation pressure
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XZLCL ! maximum height difference between
+!! ! the surface and the DPL
+!! XZPBL ! minimum mixed layer depth to sustain convection
+!! XCDEPTH ! minimum necessary cloud depth
+!! XCDEPTH_D ! maximum allowed cloud depth
+!! XDTPERT ! add small Temp peturbation
+!! XNHGAM ! coefficient for buoyancy term in w eq.
+!! ! accounting for nh-pressure
+!! XAW, XBW, XATPERT, XBTPERT
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of documentation ( routine TRIGGER_FUNCT)
+!! Fritsch and Chappell (1980), J. Atm. Sci., Vol. 37, 1722-1761.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 20/03/97 Select first departure level
+!! that produces a cloud thicker than XCDEPTH
+!! F. Bouyssel 05/11/08 Modifications for reproductibility
+!! E. Bazile 05/05/09 Modifications for using really W and the tempe.
+!! perturbation function of the TKE.
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR_SHAL
+ USE MODD_CONVPAREXT
+ USE MODI_CONVECT_SATMIXRATIO
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal loop index
+ INTEGER, INTENT(IN) :: KLEV ! vertical loop index
+ REAL, DIMENSION(KLON), INTENT(IN) :: PDXDY ! grid area
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTKECLS ! TKE CLS
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTH, PTHV ! theta, theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! envir. satur. theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRV ! vapor mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of grid point (m)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PW ! vertical velocity
+!
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PWLCL ! parcel velocity at LCL
+ REAL, DIMENSION(KLON), INTENT(OUT):: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(OUT):: OTRIG ! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KPBL ! contains index of source layer top
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: JKK, JK, JKP, JKM, JKDL, JL, JKT, JT! vertical loop index
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: IIE, IKB, IKE ! horizontal + vertical loop bounds
+ real :: ZEPS, ZEPSA ! R_d / R_v, R_v / R_d
+ real :: ZCPORD, ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON) :: ZTHLCL, ZTLCL, ZRVLCL, & ! locals for PTHLCL,PTLCL
+ ZWLCL, ZZLCL, ZTHVELCL ! PRVLCL, ....
+ INTEGER, DIMENSION(KLON) :: IDPL, IPBL, ILCL ! locals for KDPL, ...
+ REAL, DIMENSION(KLON) :: ZPLCL ! pressure at LCL
+ REAL, DIMENSION(KLON) :: ZZDPL ! height of DPL
+ REAL, DIMENSION(KLON) :: ZTHVLCL ! theta_v at LCL = mixed layer value
+ REAL, DIMENSION(KLON) :: ZTMIX ! mixed layer temperature
+ REAL, DIMENSION(KLON) :: ZEVMIX ! mixed layer water vapor pressure
+ REAL, DIMENSION(KLON) :: ZDPTHMIX, ZPRESMIX ! mixed layer depth and pressure
+ REAL, DIMENSION(KLON) :: ZCAPE ! convective available energy (m^2/s^2/g)
+ REAL, DIMENSION(KLON) :: ZCAP ! pseudo fro CAPE
+ REAL, DIMENSION(KLON) :: ZTHEUL ! updraft equiv. pot. temperature (K)
+ REAL, DIMENSION(KLON) :: ZLV, ZCPH! specific heats of vaporisation, dry air
+ REAL, DIMENSION(KLON) :: ZDP ! pressure between LCL and model layer
+ REAL, DIMENSION(KLON) :: ZTOP, ZTOPP ! estimated cloud top (m)
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3 ! work arrays
+ LOGICAL, DIMENSION(KLON) :: GTRIG, GTRIG2 ! local arrays for OTRIG
+ LOGICAL, DIMENSION(KLON) :: GWORK1 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.3 Compute array bounds
+! --------------------
+!
+ IIE = KLON
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+!
+!
+!* 1. Initialize local variables
+! --------------------------
+!
+ ZEPS = XRD / XRV
+ ZEPSA = XRV / XRD
+ ZCPORD = XCPD / XRD
+ ZRDOCP = XRD / XCPD
+ OTRIG(:) = .false.
+ IDPL(:) = KDPL(:)
+ IPBL(:) = KPBL(:)
+ ILCL(:) = KLCL(:)
+ PWLCL(:) = 0.
+ ZWLCL(:) = 0.
+ PTHLCL(:) = 1.
+ PTHVELCL(:) = 1.
+ PTLCL(:) = 1.
+ PRVLCL(:) = 0.
+ PWLCL(:) = 0.
+ PZLCL(:) = PZ(:, IKB)
+ ZZDPL(:) = PZ(:, IKB)
+ GTRIG2(:) = .true.
+!
+!
+!
+! 1. Determine highest necessary loop test layer
+! -------------------------------------------
+!
+ JT = IKE - 2
+! FBy
+!do JK = IKB + 1, IKE - 2
+! if ( PZ(1,JK) - PZ(1,IKB) < 5.E3 ) JT = JK
+!end do
+!
+!
+!* 2. Enter loop for convection test
+! ------------------------------
+!
+ JKP = MINVAL(IDPL(:)) + 1
+ JKT = JT
+ JKT = JKP ! do not allow for looping anymore, test only for surface mixed layer
+ do JKK = JKP, JKT
+!
+ GWORK1(:) = ZZDPL(:) - PZ(:, IKB) < XZLCL
+ ! we exit the trigger test when the center of the mixed layer is more
+ ! than 1500 m above soil level.
+ WHERE(GWORK1(:))
+ ZDPTHMIX(:) = 0.
+ ZPRESMIX(:) = 0.
+ ZTHLCL(:) = 0.
+ ZRVLCL(:) = 0.
+ ZZDPL(:) = PZ(:, JKK)
+ IDPL(:) = JKK
+ ENDWHERE
+!
+!
+!* 3. Construct a mixed layer of at least 50 hPa (XZPBL)
+! ------------------------------------------
+!
+ do JK = JKK, IKE - 1
+ JKM = JK + 1
+ do JI = 1, IIE
+ if(GWORK1(JI) .and. ZDPTHMIX(JI) < XZPBL) then
+ IPBL(JI) = JK
+ ZWORK1(JI) = PPRES(JI, JK) - PPRES(JI, JKM)
+ ZDPTHMIX(JI) = ZDPTHMIX(JI) + ZWORK1(JI)
+ ZPRESMIX(JI) = ZPRESMIX(JI) + PPRES(JI, JK) * ZWORK1(JI)
+ ZTHLCL(JI) = ZTHLCL(JI) + PTH(JI, JK) * ZWORK1(JI)
+ ZRVLCL(JI) = ZRVLCL(JI) + PRV(JI, JK) * ZWORK1(JI)
+ endif
+ enddo
+ if(MINVAL(ZDPTHMIX(:)) >= XZPBL) EXIT
+ enddo
+!
+!
+ WHERE(GWORK1(:))
+!
+ ZPRESMIX(:) = ZPRESMIX(:) / ZDPTHMIX(:)
+ ZTHLCL(:) = ZTHLCL(:) / ZDPTHMIX(:) + &
+ & (XATPERT * MAX(3., PTKECLS(:)) / XCPD + XBTPERT) * XDTPERT ! add small Temp Perturb.
+ ZRVLCL(:) = ZRVLCL(:) / ZDPTHMIX(:)
+ ZTHVLCL(:) = ZTHLCL(:) * (1.+ZEPSA * ZRVLCL(:)) &
+ / (1.+ZRVLCL(:))
+!
+!* 4.1 Use an empirical direct solution ( Bolton formula )
+! to determine temperature and pressure at LCL.
+! Nota: the adiabatic saturation temperature is not
+! equal to the dewpoint temperature
+! ----------------------------------------------------
+!
+!
+ ZTMIX(:) = ZTHLCL(:) * (ZPRESMIX(:) / XP00)**ZRDOCP
+ ZEVMIX(:) = ZRVLCL(:) * ZPRESMIX(:) / (ZRVLCL(:) + ZEPS)
+ ZEVMIX(:) = MAX(1.E-8, ZEVMIX(:))
+ ZWORK1(:) = LOG(ZEVMIX(:) / 613.3)
+ ! dewpoint temperature
+ ZWORK1(:) = (4780.8 - 32.19 * ZWORK1(:)) / (17.502 - ZWORK1(:))
+ ! adiabatic saturation temperature
+ ZTLCL(:) = ZWORK1(:) - (.212 + 1.571E-3 * (ZWORK1(:) - XTT) &
+ - 4.36E-4 * (ZTMIX(:) - XTT)) * (ZTMIX(:) - ZWORK1(:))
+ ZTLCL(:) = MIN(ZTLCL(:), ZTMIX(:))
+ ZPLCL(:) = XP00 * (ZTLCL(:) / ZTHLCL(:))**ZCPORD
+!
+ ENDWHERE
+!
+!
+!* 4.2 Correct ZTLCL in order to be completely consistent
+! with MNH saturation formula
+! ---------------------------------------------
+!
+ call CONVECT_SATMIXRATIO(KLON, ZPLCL, ZTLCL, ZWORK1, ZLV, ZWORK2, ZCPH)
+ WHERE(GWORK1(:))
+ ZWORK2(:) = ZWORK1(:) / ZTLCL(:) * (XBETAW / ZTLCL(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = (ZWORK1(:) - ZRVLCL(:)) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:))
+ ZTLCL(:) = ZTLCL(:) - ZLV(:) / ZCPH(:) * ZWORK2(:)
+!
+ ENDWHERE
+!
+!
+!* 4.3 If ZRVLCL = PRVMIX is oversaturated set humidity
+! and temperature to saturation values.
+! ---------------------------------------------
+!
+ call CONVECT_SATMIXRATIO(KLON, ZPRESMIX, ZTMIX, ZWORK1, ZLV, ZWORK2, ZCPH)
+ WHERE(GWORK1(:) .and. ZRVLCL(:) > ZWORK1(:))
+ ZWORK2(:) = ZWORK1(:) / ZTMIX(:) * (XBETAW / ZTMIX(:) - XGAMW) ! dr_sat/dT
+ ZWORK2(:) = (ZWORK1(:) - ZRVLCL(:)) / &
+ (1.+ZLV(:) / ZCPH(:) * ZWORK2(:))
+ ZTLCL(:) = ZTMIX(:) - ZLV(:) / ZCPH(:) * ZWORK2(:)
+ ZRVLCL(:) = ZRVLCL(:) - ZWORK2(:)
+ ZPLCL(:) = ZPRESMIX(:)
+ ZTHLCL(:) = ZTLCL(:) * (XP00 / ZPLCL(:))**ZRDOCP
+ ZTHVLCL(:) = ZTHLCL(:) * (1.+ZEPSA * ZRVLCL(:)) &
+ / (1.+ZRVLCL(:))
+ ENDWHERE
+!
+!
+!* 5.1 Determine vertical loop index at the LCL and DPL
+! --------------------------------------------------
+!
+ do JK = JKK, IKE - 1
+ do JI = 1, IIE
+ if(ZPLCL(JI) <= PPRES(JI, JK) .and. GWORK1(JI)) ILCL(JI) = JK + 1
+ enddo
+ enddo
+!
+!
+!* 5.2 Estimate height and environm. theta_v at LCL
+! --------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = ILCL(JI)
+ JKM = JK - 1
+ ZDP(JI) = LOG(ZPLCL(JI) / PPRES(JI, JKM)) / &
+ LOG(PPRES(JI, JK) / PPRES(JI, JKM))
+ ZWORK1(JI) = PTHV(JI, JKM) + (PTHV(JI, JK) - PTHV(JI, JKM)) * ZDP(JI)
+ ! we compute the precise value of the LCL
+ ! The precise height is between the levels ILCL and ILCL-1.
+ ZWORK2(JI) = PZ(JI, JKM) + (PZ(JI, JK) - PZ(JI, JKM)) * ZDP(JI)
+ enddo
+ WHERE(GWORK1(:))
+ ZTHVELCL(:) = ZWORK1(:)
+ ZZLCL(:) = ZWORK2(:)
+ ENDWHERE
+!
+!
+!* 6. Check to see if cloud is bouyant
+! --------------------------------
+!
+!* 6.1 Compute grid scale vertical velocity perturbation term ZWORK1
+! -------------------------------------------------------------
+!
+! ! normalize w grid scale to a 25 km refer. grid
+! do JI = 1, IIE
+! JK = ILCL(JI)
+! JKM = JK - 1
+! ZWORK1(JI) = ( PW(JI,JKM) + ( PW(JI,JK) - PW(JI,JKM) ) * ZDP(JI) ) &
+! * SQRT( PDXDY(JI) / XA25 )
+! - 0.02 * ZZLCL(JI) / XZLCL ! avoid spurious convection
+! end do
+! ! compute sign of normalized grid scale w
+! ZWORK2(:) = SIGN( 1., ZWORK1(:) )
+! ZWORK1(:) = XWTRIG * ZWORK2(:) * ABS( ZWORK1(:) ) ** 0.333 &
+! * ( XP00 / ZPLCL(:) ) ** ZRDOCP
+!
+!* 6.2 Compute parcel vertical velocity at LCL
+! ---------------------------------------
+!
+! do JI = 1, IIE
+! JKDL = IDPL(JI)
+! ZWORK3(JI) = XG * ZWORK1(JI) * ( ZZLCL(JI) - PZ(JI,JKDL) ) &
+! / ( PTHV(JI,JKDL) + ZTHVELCL(JI) )
+! end do
+! WHERE( GWORK1(:) )
+! ZWLCL(:) = 1. + .5 * ZWORK2(:) * SQRT( ABS( ZWORK3(:) ) )
+! GTRIG(:) = ZTHVLCL(:) - ZTHVELCL(:) + ZWORK1(:) > 0. .and. &
+! ZWLCL(:) > 0.
+! END WHERE
+ ZWLCL(:) = XAW * MAX(0., PW(:, IKB)) + XBW
+!
+!
+!* 6.3 Look for parcel that produces sufficient cloud depth.
+! The cloud top is estimated as the level where the CAPE
+! is smaller than a given value (based on vertical velocity eq.)
+! --------------------------------------------------------------
+!
+ ZTHEUL(:) = ZTLCL(:) * (ZTHLCL(:) / ZTLCL(:)) &
+ **(1.-0.28 * ZRVLCL(:)) &
+ * EXP((3374.6525 / ZTLCL(:) - 2.5403) * &
+ ZRVLCL(:) * (1.+0.81 * ZRVLCL(:)))
+!
+ ZCAPE(:) = 0.
+ ZCAP(:) = 0.
+ ZTOP(:) = 0.
+ ZTOPP(:) = 0.
+ ZWORK3(:) = 0.
+ JKM = MINVAL(ILCL(:))
+ do JL = JKM, JT
+ JK = JL + 1
+ do JI = 1, IIE
+ ZWORK1(JI) = (2.*ZTHEUL(JI) / &
+ (PTHES(JI, JK) + PTHES(JI, JL)) - 1.) * (PZ(JI, JK) - PZ(JI, JL))
+ if(JL < ILCL(JI)) ZWORK1(JI) = 0.
+ ZCAPE(JI) = ZCAPE(JI) + XG * MAX(1., ZWORK1(JI))
+ ZCAP(JI) = ZCAP(JI) + ZWORK1(JI)
+ ZWORK2(JI) = XNHGAM * XG * ZCAP(JI) + 1.05 * ZWLCL(JI) * ZWLCL(JI)
+ ! the factor 1.05 takes entrainment into account
+ ZWORK2(JI) = SIGN(1., ZWORK2(JI))
+ ZWORK3(JI) = ZWORK3(JI) + MIN(0., ZWORK2(JI))
+ ZWORK3(JI) = MAX(-1., ZWORK3(JI))
+ ! Nota, the factors ZWORK2 and ZWORK3 are only used to avoid
+ ! if and goto statements, the difficulty is to extract only
+ ! the level where the criterium is first fullfilled
+ ZTOPP(JI) = ZTOP(JI)
+ ZTOP(JI) = PZ(JI, JL)*.5 * (1.+ZWORK2(JI)) * (1.+ZWORK3(JI)) + &
+ ZTOP(JI)*.5 * (1.-ZWORK2(JI))
+ ZTOP(JI) = MAX(ZTOP(JI), ZTOPP(JI))
+ ZTOPP(JI) = ZTOP(JI)
+ enddo
+ enddo
+!
+!
+ ZWORK2(:) = ZTOP(:) - ZZLCL(:)
+ ! WHERE( ZWORK2(:) .GE. XCDEPTH .and. ZWORK2(:) < XCDEPTH_D .and. GTRIG2(:) &
+ WHERE(ZWORK2(:) >= XCDEPTH .and. GTRIG2(:) &
+ .and. ZCAPE(:) > 10.)
+ GTRIG2(:) = .false.
+ OTRIG(:) = .true.
+ ! OTRIG(:) = GTRIG(:) ! we select the first departure level
+ PTHLCL(:) = ZTHLCL(:) ! that gives sufficient cloud depth
+ PRVLCL(:) = ZRVLCL(:)
+ PTLCL(:) = ZTLCL(:)
+ PWLCL(:) = ZWLCL(:)
+ PZLCL(:) = ZZLCL(:)
+ PTHVELCL(:) = ZTHVELCL(:)
+ KDPL(:) = IDPL(:)
+ KPBL(:) = IPBL(:)
+ KLCL(:) = ILCL(:)
+ ENDWHERE
+!
+ enddo
+!
+!
+ENDsubroutine CONVECT_TRIGGER_SHAL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! #################
+MODULE MODI_CONVECT_UPDRAFT_SHAL
+! #################
+!
+ INTERFACE
+!
+ subroutine CONVECT_UPDRAFT_SHAL(KLON, KLEV, &
+ KICE, PPRES, PDPRES, PZ, PTHL, PTHV, PTHES, PRW, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, PTHVELCL, &
+ PMFLCL, OTRIG, KLCL, KDPL, KPBL, &
+ PUMF, PUER, PUDR, PUTHL, PUTHV, PURW, &
+ PURC, PURI, PCAPE, KCTL, KETL)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHV ! grid scale theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! grid scale saturated theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PWLCL ! parcel velocity at LCL (m/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMFLCL ! cloud base unit mass flux
+ ! (kg/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(INOUT):: OTRIG! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! " vert. index of source layertop
+!
+!
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KETL ! contains vert. index of &
+ !equilibrium (zero buoyancy) level
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHV ! updraft theta_v (K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURI ! updraft cloud ice (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCAPE ! available potent. energy
+!
+ ENDsubroutine CONVECT_UPDRAFT_SHAL
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_CONVECT_UPDRAFT_SHAL
+! ###############################################################################
+subroutine CONVECT_UPDRAFT_SHAL(KLON, KLEV, &
+ KICE, PPRES, PDPRES, PZ, PTHL, PTHV, PTHES, PRW, &
+ PTHLCL, PTLCL, PRVLCL, PWLCL, PZLCL, PTHVELCL, &
+ PMFLCL, OTRIG, KLCL, KDPL, KPBL, &
+ PUMF, PUER, PUDR, PUTHL, PUTHV, PURW, &
+ PURC, PURI, PCAPE, KCTL, KETL)
+! ###############################################################################
+!
+!!**** Compute updraft properties from DPL to CTL.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine updraft properties
+!! ( mass flux, thermodynamics, precipitation )
+!!
+!!
+!!** METHOD
+!! ------
+!! Computations are done at every model level starting from bottom.
+!! The use of masks allows to optimise the inner loops (horizontal loops).
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Routine CONVECT_MIXING_FUNCT
+!! Routine CONVECT_CONDENS
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV, XCL ! Cp of dry air, water vapor and liquid water
+!! XTT ! triple point temperature
+!! XLVTT ! vaporisation heat at XTT
+!!
+!!
+!! Module MODD_CONVPAR_SHAL
+!! XA25 ! reference grid area
+!! XCRAD ! cloud radius
+!! XCDEPTH ! minimum necessary cloud depth
+!! XENTR ! entrainment constant
+!! XNHGAM ! coefficient for buoyancy term in w eq.
+!! ! accounting for nh-pressure
+!! XTFRZ1 ! begin of freezing interval
+!! XTFRZ2 ! begin of freezing interval
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book1,2 of documentation ( routine CONVECT_UPDRAFT)
+!! Kain and Fritsch, 1990, J. Atmos. Sci., Vol.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/11/95
+!! Last modified 10/12/97
+!! F. Bouyssel 05/11/08 Modifications for reproductibility
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAR_SHAL
+ USE MODD_CONVPAREXT
+ USE MODI_CONVECT_CONDENS
+ USE MODI_CONVECT_MIXING_FUNCT
+!
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHV ! grid scale theta_v
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTHES ! grid scale saturated theta_e
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRW ! grid scale total water
+ ! mixing ratio
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPRES ! pressure (P)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PDPRES! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHLCL ! theta at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTLCL ! temp. at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PRVLCL ! vapor mixing ratio at LCL
+ REAL, DIMENSION(KLON), INTENT(IN) :: PWLCL ! parcel velocity at LCL (m/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PMFLCL ! cloud base unit mass flux
+ ! (kg/s)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PZLCL ! height at LCL (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTHVELCL ! environm. theta_v at LCL (K)
+ LOGICAL, DIMENSION(KLON), INTENT(INOUT):: OTRIG! logical mask for convection
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KLCL ! contains vert. index of LCL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KDPL ! contains vert. index of DPL
+ INTEGER, DIMENSION(KLON), INTENT(IN) :: KPBL ! " vert. index of source layertop
+!
+!
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KCTL ! contains vert. index of CTL
+ INTEGER, DIMENSION(KLON), INTENT(OUT):: KETL ! contains vert. index of &
+ !equilibrium (zero buoyancy) level
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PUTHV ! updraft theta_v (K)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(KLON, KLEV), INTENT(OUT):: PURI ! updraft cloud ice (kg/kg)
+ REAL, DIMENSION(KLON), INTENT(OUT):: PCAPE ! available potent. energy
+!
+!* 0.2 Declarations of local variables :
+!
+ INTEGER :: IIE, IKB, IKE ! horizontal and vertical loop bounds
+ INTEGER :: JI ! horizontal loop index
+ INTEGER :: JK, JKP, JKM, JK1, JK2 ! vertical loop index
+ real :: ZEPSA ! R_v / R_d, C_pv / C_pd
+ real :: ZRDOCP ! C_pd / R_d, R_d / C_pd
+!
+ REAL, DIMENSION(KLON) :: ZUT ! updraft temperature (K)
+ REAL, DIMENSION(KLON) :: ZUW1, ZUW2 ! square of updraft vert.
+ ! velocity at levels k and k+1
+ REAL, DIMENSION(KLON) :: ZE1, ZE2, ZD1, ZD2 ! fractional entrainm./detrain
+ ! rates at levels k and k+1
+ REAL, DIMENSION(KLON) :: ZMIXF ! critical mixed fraction
+ REAL, DIMENSION(KLON) :: ZCPH ! specific heat C_ph
+ REAL, DIMENSION(KLON) :: ZLV, ZLS ! latent heat of vaporis., sublim.
+ REAL, DIMENSION(KLON) :: ZURV ! updraft water vapor at level k+1
+ REAL, DIMENSION(KLON) :: ZPI ! Pi=(P0/P)**(Rd/Cpd)
+ REAL, DIMENSION(KLON) :: ZTHEUL ! theta_e for undilute ascent
+ REAL, DIMENSION(KLON) :: ZWORK1, ZWORK2, ZWORK3, ZWORK4, ZWORK5, &
+ ZWORK6 ! work arrays
+ INTEGER, DIMENSION(KLON) :: IWORK ! wok array
+ LOGICAL, DIMENSION(KLON) :: GWORK1, GWORK2, GWORK4, GWORK5
+ ! work arrays
+ LOGICAL, DIMENSION(KLON, KLEV) :: GWORK6 ! work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+! 0.3 Set loop bounds
+! ---------------
+!
+ IKB = 1 + JCVEXB
+ IKE = KLEV - JCVEXT
+ IIE = KLON
+!
+!
+!* 1. Initialize updraft properties and local variables
+! -------------------------------------------------
+!
+ ZEPSA = XRV / XRD
+ ZRDOCP = XRD / XCPD
+!
+ PUMF(:, :) = 0.
+ PUER(:, :) = 0.
+ PUDR(:, :) = 0.
+ PUTHL(:, :) = 0.
+ PUTHV(:, :) = 0.
+ PURW(:, :) = 0.
+ PURC(:, :) = 0.
+ PURI(:, :) = 0.
+ ZUW1(:) = PWLCL(:) * PWLCL(:)
+ ZUW2(:) = 0.
+ ZE1(:) = 0.
+ ZD1(:) = 0.
+ PCAPE(:) = 0.
+ KCTL(:) = IKB
+ KETL(:) = KLCL(:)
+ GWORK2(:) = .true.
+ ZPI(:) = 1.
+ ZWORK3(:) = 0.
+ ZWORK4(:) = 0.
+ ZWORK5(:) = 0.
+ ZWORK6(:) = 0.
+ GWORK1(:) = .false.
+ GWORK4(:) = .false.
+!
+!
+!* 1.1 Compute undilute updraft theta_e for CAPE computations
+! Bolton (1980) formula.
+! Define accurate enthalpy for updraft
+! -----------------------------------------------------
+!
+ ZTHEUL(:) = PTLCL(:) * (PTHLCL(:) / PTLCL(:))**(1.-0.28 * PRVLCL(:)) &
+ * EXP((3374.6525 / PTLCL(:) - 2.5403) * &
+ PRVLCL(:) * (1.+0.81 * PRVLCL(:)))
+!
+!
+ ZWORK1(:) = (XCPD + PRVLCL(:) * XCPV) * PTLCL(:) &
+ + (1.+PRVLCL(:)) * XG * PZLCL(:)
+!
+!
+!* 2. Set updraft properties between DPL and LCL
+! ------------------------------------------
+!
+ JKP = MAXVAL(KLCL(:))
+ JKM = MINVAL(KDPL(:))
+ do JK = JKM, JKP
+ do JI = 1, IIE
+ if(JK >= KDPL(JI) .and. JK < KLCL(JI)) then
+ PUMF(JI, JK) = PMFLCL(JI)
+ PUTHL(JI, JK) = ZWORK1(JI)
+ PUTHV(JI, JK) = PTHLCL(JI) * (1.+ZEPSA * PRVLCL(JI)) / &
+ (1.+PRVLCL(JI))
+ PURW(JI, JK) = PRVLCL(JI)
+ endif
+ enddo
+ enddo
+!
+!
+!* 3. Enter loop for updraft computations
+! ------------------------------------
+!
+ do JK = IKB + 1, IKE - 1
+ ZWORK6(:) = 1.
+ JKP = JK + 1
+!
+ GWORK4(:) = JK >= KLCL(:) - 1
+ GWORK1(:) = GWORK4(:) .and. GWORK2(:) ! this mask is used to confine
+ ! updraft computations between the LCL and the CTL
+!
+ WHERE(JK == KLCL(:) - 1) ZWORK6(:) = 0. ! factor that is used in buoyancy
+ ! computation at first level above LCL
+!
+!
+!* 4. Estimate condensate, L_v L_i, Cph and theta_v at level k+1
+! ----------------------------------------------------------
+!
+ ZWORK1(:) = PURC(:, JK)
+ ZWORK2(:) = PURI(:, JK)
+ call CONVECT_CONDENS(KLON, KICE, PPRES(:, JKP), PUTHL(:, JK), PURW(:, JK), &
+ ZWORK1, ZWORK2, PZ(:, JKP), GWORK1, ZUT, ZURV, &
+ PURC(:, JKP), PURI(:, JKP), ZLV, ZLS, ZCPH)
+!
+!
+ ZPI(:) = (XP00 / PPRES(:, JKP))**ZRDOCP
+ WHERE(GWORK1(:))
+!
+ PUTHV(:, JKP) = ZPI(:) * ZUT(:) * (1.+ZEPSA * ZURV(:)) &
+ / (1.+PURW(:, JK))
+!
+!
+!* 5. Compute square of vertical velocity using entrainment
+! at level k
+! -----------------------------------------------------
+!
+ ZWORK3(:) = PZ(:, JKP) - PZ(:, JK) * ZWORK6(:) - &
+ (1.-ZWORK6(:)) * PZLCL(:) ! level thickness
+ ZWORK4(:) = PTHV(:, JK) * ZWORK6(:) + &
+ (1.-ZWORK6(:)) * PTHVELCL(:)
+ ZWORK5(:) = 2.*ZUW1(:) * PUER(:, JK) / MAX(.1, PUMF(:, JK))
+ ZUW2(:) = ZUW1(:) + ZWORK3(:) * XNHGAM * XG * &
+ ((PUTHV(:, JK) + PUTHV(:, JKP)) / &
+ (ZWORK4(:) + PTHV(:, JKP)) - 1.) & ! buoyancy term
+ - ZWORK5(:) ! entrainment term
+!
+!
+!* 6. Update total precipitation: dr_r=(r_c+r_i)*exp(-rate*dz)
+! --------------------------------------------------------
+!
+! compute level mean vertical velocity
+ ZWORK2(:) = 0.5 * &
+ (SQRT(MAX(1.E-2, ZUW2(:))) + &
+ SQRT(MAX(1.E-2, ZUW1(:))))
+!
+!
+!* 7. Update r_c, r_i, enthalpy, r_w for precipitation
+! -------------------------------------------------------
+!
+ PURW(:, JKP) = PURW(:, JK)
+ PURC(:, JKP) = PURC(:, JKP)
+ PURI(:, JKP) = PURI(:, JKP)
+ PUTHL(:, JKP) = PUTHL(:, JK)
+!
+ ZUW1(:) = ZUW2(:)
+!
+ ENDWHERE
+!
+!
+!* 8. Compute entrainment and detrainment using conservative
+! variables adjusted for precipitation ( not for entrainment)
+! -----------------------------------------------------------
+!
+!* 8.1 Compute critical mixed fraction by estimating unknown
+! T^mix r_c^mix and r_i^mix from enthalpy^mix and r_w^mix
+! We determine the zero crossing of the linear curve
+! evaluating the derivative using ZMIXF=0.1.
+! -----------------------------------------------------
+!
+ ZMIXF(:) = 0.1 ! starting value for critical mixed fraction
+ ZWORK1(:) = ZMIXF(:) * PTHL(:, JKP) &
+ + (1.-ZMIXF(:)) * PUTHL(:, JKP) ! mixed enthalpy
+ ZWORK2(:) = ZMIXF(:) * PRW(:, JKP) &
+ + (1.-ZMIXF(:)) * PURW(:, JKP) ! mixed r_w
+!
+ call CONVECT_CONDENS(KLON, KICE, PPRES(:, JKP), ZWORK1, ZWORK2, &
+ PURC(:, JKP), PURI(:, JKP), PZ(:, JKP), GWORK1, ZUT, &
+ ZWORK3, ZWORK4, ZWORK5, ZLV, ZLS, ZCPH)
+! put in enthalpy and r_w and get T r_c, r_i (ZUT, ZWORK4-5)
+!
+ ! compute theta_v of mixture
+ ZWORK3(:) = ZUT(:) * ZPI(:) * (1.+ZEPSA * ( &
+ ZWORK2(:) - ZWORK4(:) - ZWORK5(:))) / (1.+ZWORK2(:))
+ ! compute final value of critical mixed fraction using theta_v
+ ! of mixture, grid-scale and updraft
+ ZMIXF(:) = MAX(0., PUTHV(:, JKP) - PTHV(:, JKP)) * ZMIXF(:) / &
+ (PUTHV(:, JKP) - ZWORK3(:) + 1.E-10)
+ ZMIXF(:) = MAX(0., MIN(1., ZMIXF(:)))
+!
+!
+!* 8.2 Compute final midlevel values for entr. and detrainment
+! after call of distribution function
+! -------------------------------------------------------
+!
+!
+ call CONVECT_MIXING_FUNCT(KLON, ZMIXF, 1, ZE2, ZD2)
+! Note: routine MIXING_FUNCT returns fractional entrainm/detrainm. rates
+!
+ ZE2 = MIN(ZD2, MAX(.3, ZE2))
+!
+! ZWORK1(:) = XENTR * PMFLCL(:) * PDPRES(:,JKP) / XCRAD ! rate of env. inflow
+!*MOD
+ zwork1(:) = xentr * xg / xcrad * pumf(:, jk) * (pz(:, jkp) - pz(:, jk))
+! ZWORK1(:) = XENTR * pumf(:,jk) * PDPRES(:,JKP) / XCRAD ! rate of env. inflow
+!*MOD
+ ZWORK2(:) = 0.
+ WHERE(GWORK1(:)) ZWORK2(:) = 1.
+ WHERE(PUTHV(:, JKP) > PTHV(:, JKP))
+ PUER(:, JKP) = 0.5 * ZWORK1(:) * (ZE1(:) + ZE2(:)) * ZWORK2(:)
+ PUDR(:, JKP) = 0.5 * ZWORK1(:) * (ZD1(:) + ZD2(:)) * ZWORK2(:)
+ elseWHERE
+ PUER(:, JKP) = 0.
+ PUDR(:, JKP) = ZWORK1(:) * ZWORK2(:)
+ ENDWHERE
+!
+!* 8.3 Determine equilibrium temperature level
+! --------------------------------------
+!
+ WHERE(PUTHV(:, JKP) > PTHV(:, JKP) .and. JK > KLCL(:) + 1 &
+ .and. GWORK1(:))
+ KETL(:) = JKP ! equilibrium temperature level
+ ENDWHERE
+!
+!* 8.4 If the calculated detrained mass flux is greater than
+! the total updraft mass flux, or vertical velocity is
+! negative, all cloud mass detrains at previous model level,
+! exit updraft calculations - CTL is attained
+! -------------------------------------------------------
+!
+ WHERE(GWORK1(:)) &
+ GWORK2(:) = PUMF(:, JK) - PUDR(:, JKP) > 10. .and. ZUW2(:) > 0.
+ WHERE(GWORK2(:)) KCTL(:) = JKP ! cloud top level
+ GWORK1(:) = GWORK2(:) .and. GWORK4(:)
+!
+ if(COUNT(GWORK2(:)) == 0) EXIT
+!
+!
+!* 9. Compute CAPE for undilute ascent using theta_e and
+! theta_es instead of theta_v. This estimation produces
+! a significantly larger value for CAPE than the actual one.
+! ----------------------------------------------------------
+!
+ WHERE(GWORK1(:))
+!
+ ZWORK3(:) = PZ(:, JKP) - PZ(:, JK) * ZWORK6(:) - &
+ (1.-ZWORK6(:)) * PZLCL(:) ! level thickness
+ ZWORK2(:) = PTHES(:, JK) + (1.-ZWORK6(:)) * &
+ (PTHES(:, JKP) - PTHES(:, JK)) / (PZ(:, JKP) - PZ(:, JK)) * &
+ (PZLCL(:) - PZ(:, JK)) ! linear interpolation for theta_es at LCL
+ ! ( this is only done for model level just above LCL
+!
+ ZWORK1(:) = (2.*ZTHEUL(:)) / (ZWORK2(:) + PTHES(:, JKP)) - 1.
+ PCAPE(:) = PCAPE(:) + XG * ZWORK3(:) * MAX(0., ZWORK1(:))
+!
+!
+!* 10. Compute final values of updraft mass flux, enthalpy, r_w
+! at level k+1
+! --------------------------------------------------------
+!
+ PUMF(:, JKP) = PUMF(:, JK) - PUDR(:, JKP) + PUER(:, JKP)
+ PUMF(:, JKP) = MAX(PUMF(:, JKP), 0.1)
+ PUTHL(:, JKP) = (PUMF(:, JK) * PUTHL(:, JK) + &
+ PUER(:, JKP) * PTHL(:, JK) - PUDR(:, JKP) * PUTHL(:, JK)) &
+ / PUMF(:, JKP)
+ PURW(:, JKP) = (PUMF(:, JK) * PURW(:, JK) + &
+ PUER(:, JKP) * PRW(:, JK) - PUDR(:, JKP) * PURW(:, JK)) &
+ / PUMF(:, JKP)
+!
+!
+ ZE1(:) = ZE2(:) ! update fractional entrainment/detrainment
+ ZD1(:) = ZD2(:)
+!
+ ENDWHERE
+!
+ enddo
+!
+!* 12.1 Set OTRIG to False if cloud thickness < 0.5km
+! or > 3km (deep convection) or CAPE < 1
+! ------------------------------------------------
+!
+ do JI = 1, IIE
+ JK = KCTL(JI)
+ ZWORK1(JI) = PZ(JI, JK) - PZLCL(JI)
+ OTRIG(JI) = ZWORK1(JI) >= XCDEPTH .and. ZWORK1(JI) < XCDEPTH_D &
+ .and. PCAPE(JI) > 1.
+ enddo
+ WHERE(.not. OTRIG(:))
+ KCTL(:) = IKB
+ ENDWHERE
+ KETL(:) = MAX(KETL(:), KLCL(:) + 2)
+ KETL(:) = MIN(KETL(:), KCTL(:))
+!
+!
+!* 12.2 If the ETL and CTL are the same detrain updraft mass
+! flux at this level
+! -------------------------------------------------------
+!
+ ZWORK1(:) = 0.
+ WHERE(KETL(:) == KCTL(:)) ZWORK1(:) = 1.
+!
+ do JI = 1, IIE
+ JK = KETL(JI)
+ PUDR(JI, JK) = PUDR(JI, JK) + &
+ (PUMF(JI, JK) - PUER(JI, JK)) * ZWORK1(JI)
+ PUER(JI, JK) = PUER(JI, JK) * (1.-ZWORK1(JI))
+ PUMF(JI, JK) = PUMF(JI, JK) * (1.-ZWORK1(JI))
+ JKP = KCTL(JI) + 1
+ PUER(JI, JKP) = 0. ! entrainm/detr rates have been already computed
+ PUDR(JI, JKP) = 0. ! at level KCTL+1, set them to zero
+ PURW(JI, JKP) = 0.
+ PURC(JI, JKP) = 0.
+ PURI(JI, JKP) = 0.
+ PUTHL(JI, JKP) = 0.
+ PURC(JI, JKP + 1) = 0.
+ PURI(JI, JKP + 1) = 0.
+ enddo
+!
+!* 12.3 Adjust mass flux profiles, detrainment rates, and
+! precipitation fallout rates to reflect linear decrease
+! in mass flux between the ETL and CTL
+! -------------------------------------------------------
+!
+ ZWORK1(:) = 0.
+ JK1 = MINVAL(KETL(:))
+ JK2 = MAXVAL(KCTL(:))
+
+ do JK = JK1, JK2
+ do JI = 1, IIE
+ if(JK > KETL(JI) .and. JK <= KCTL(JI)) then
+ ZWORK1(JI) = ZWORK1(JI) + PDPRES(JI, JK)
+ endif
+ enddo
+ enddo
+!
+ do JI = 1, IIE
+ JK = KETL(JI)
+ ZWORK1(JI) = PUMF(JI, JK) / MAX(1., ZWORK1(JI))
+ enddo
+!
+ do JK = JK1 + 1, JK2
+ JKP = JK - 1
+ do JI = 1, IIE
+ if(JK > KETL(JI) .and. JK <= KCTL(JI)) then
+ PUDR(JI, JK) = PDPRES(JI, JK) * ZWORK1(JI)
+ PUMF(JI, JK) = PUMF(JI, JKP) - PUDR(JI, JK)
+ endif
+ enddo
+ enddo
+!
+! 12.4 Set mass flux and entrainment in the source layer.
+! Linear increase throughout the source layer.
+! -------------------------------------------------------
+!
+!IWORK(:) = MIN( KPBL(:), KLCL(:) - 1 )
+ IWORK(:) = KPBL(:)
+ do JI = 1, IIE
+ JK = KDPL(JI)
+ JKP = IWORK(JI)
+! mixed layer depth
+ ZWORK2(JI) = PPRES(JI, JK) - PPRES(JI, JKP) + PDPRES(JI, JK)
+ enddo
+!
+ JKP = MAXVAL(IWORK(:))
+ do JK = JKM, JKP
+ do JI = 1, IIE
+ if(JK >= KDPL(JI) .and. JK <= IWORK(JI)) then
+ PUER(JI, JK) = PUER(JI, JK) + PMFLCL(JI) * PDPRES(JI, JK) / (ZWORK2(JI) + 0.1)
+ PUMF(JI, JK) = PUMF(JI, JK - 1) + PUER(JI, JK)
+ endif
+ enddo
+ enddo
+!
+!
+!* 13. If cloud thickness is smaller than .5 km or > 3 km
+! no shallow convection is allowed
+! Nota: For technical reasons, we stop the convection
+! computations in this case and do not go back to
+! TRIGGER_FUNCT to look for the next unstable LCL
+! which could produce a thicker cloud.
+! ---------------------------------------------------
+!
+ GWORK6(:, :) = SPREAD(OTRIG(:), DIM=2, NCOPIES=KLEV)
+ WHERE(.not. GWORK6(:, :))
+ PUMF(:, :) = 0.
+ PUDR(:, :) = 0.
+ PUER(:, :) = 0.
+ PUTHL(:, :) = PTHL(:, :)
+ PURW(:, :) = PRW(:, :)
+ PURC(:, :) = 0.
+ PURI(:, :) = 0.
+ ENDWHERE
+!
+ENDsubroutine CONVECT_UPDRAFT_SHAL
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! MASDEV4_7 conv 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ######################
+MODULE MODI_SHALLOW_CONVECTION
+! ######################
+!
+ INTERFACE
+!
+ subroutine SHALLOW_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OSETTADJ, PTADJS, &
+ PPABST, PZZ, PTKECLS, &
+ PTT, PRVT, PRCT, PRIT, PWT, &
+ PTTEN, PRVTEN, PRCTEN, PRITEN, &
+ KCLTOP, KCLBAS, PUMF, &
+ OCH1CONV, KCH1, PCH1, PCH1TEN)
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KIDIA ! value of the first point in x
+ INTEGER, INTENT(IN) :: KFDIA ! value of the last point in x
+ INTEGER, INTENT(IN) :: KBDIA ! vertical computations start at
+! ! KBDIA that is at least 1
+ INTEGER, INTENT(IN) :: KTDIA ! vertical computations can be
+ ! limited to KLEV + 1 - KTDIA
+ ! default=1
+ REAL, INTENT(IN) :: PDTCONV ! Interval of time between two
+ ! calls of the deep convection
+ ! scheme
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ LOGICAL, INTENT(IN) :: OSETTADJ ! logical to set convective
+ ! adjustment time by user
+ REAL, INTENT(IN) :: PTADJS ! user defined adjustment time
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTT ! grid scale temperature at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRVT ! grid scale water vapor "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRCT ! grid scale r_c "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRIT ! grid scale r_i "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PWT ! grid scale vertical
+ ! velocity (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPABST ! grid scale pressure at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTKECLS ! TKE in the CLS (m2/s2)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PTTEN ! convective temperature
+ ! tendency (K/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRVTEN ! convective r_v tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRCTEN ! convective r_c tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRITEN ! convective r_i tendency (1/s)
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLTOP ! cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLBAS ! cloud base level
+ ! they are given a value of
+ ! 0 if no convection
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s m2)
+!
+ LOGICAL, INTENT(IN) :: OCH1CONV ! include tracer transport
+ INTEGER, INTENT(IN) :: KCH1 ! number of species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(IN) :: PCH1! grid scale chemical species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(INOUT):: PCH1TEN! species conv. tendency (1/s)
+!
+ ENDsubroutine SHALLOW_CONVECTION
+!
+ ENDINTERFACE
+!
+ENDMODULE MODI_SHALLOW_CONVECTION
+! ###############################################################################
+subroutine SHALLOW_CONVECTION(KLON, KLEV, KIDIA, KFDIA, KBDIA, KTDIA, &
+ PDTCONV, KICE, OSETTADJ, PTADJS, &
+ PPABST, PZZ, PTKECLS, &
+ PTT, PRVT, PRCT, PRIT, PWT, &
+ PTTEN, PRVTEN, PRCTEN, PRITEN, &
+ KCLTOP, KCLBAS, PUMF, &
+ OCH1CONV, KCH1, PCH1, PCH1TEN)
+! ###############################################################################
+!
+!!**** Monitor routine to compute all convective tendencies by calls
+!! of several subroutines.
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to determine the convective
+!! tendencies. The routine first prepares all necessary grid-scale
+!! variables. The final convective tendencies are then computed by
+!! calls of different subroutines.
+!!
+!!
+!!** METHOD
+!! ------
+!! We start by selecting convective columns in the model domain through
+!! the call of routine TRIGGER_FUNCT. Then, we allocate memory for the
+!! convection updraft and downdraft variables and gather the grid scale
+!! variables in convective arrays.
+!! The updraft and downdraft computations are done level by level starting
+!! at the bottom and top of the domain, respectively.
+!! All computations are done on MNH thermodynamic levels. The depth
+!! of the current model layer k is defined by DP(k)=P(k-1)-P(k)
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! CONVECT_TRIGGER_SHAL
+!! CONVECT_SATMIXRATIO
+!! CONVECT_UPDRAFT_SHAL
+!! CONVECT_CONDENS
+!! CONVECT_MIXING_FUNCT
+!! CONVECT_CLOSURE_SHAL
+!! CONVECT_CLOSURE_THRVLCL
+!! CONVECT_CLOSURE_ADJUST_SHAL
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XG ! gravity constant
+!! XPI ! number Pi
+!! XP00 ! reference pressure
+!! XRD, XRV ! gaz constants for dry air and water vapor
+!! XCPD, XCPV ! specific heat for dry air and water vapor
+!! XRHOLW ! density of liquid water
+!! XALPW, XBETAW, XGAMW ! constants for water saturation pressure
+!! XTT ! triple point temperature
+!! XLVTT, XLSTT ! vaporization, sublimation heat constant
+!! XCL, XCI ! specific heat for liquid water and ice
+!!
+!! Module MODD_CONVPAREXT
+!! JCVEXB, JCVEXT ! extra levels on the vertical boundaries
+!!
+!! Module MODD_CONVPAR
+!! XA25 ! reference grid area
+!! XCRAD ! cloud radius
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Bechtold, 1997 : Meso-NH scientific documentation (31 pp)
+!! Fritsch and Chappell, 1980, J. Atmos. Sci., Vol. 37, 1722-1761.
+!! Kain and Fritsch, 1990, J. Atmos. Sci., Vol. 47, 2784-2801.
+!! Kain and Fritsch, 1993, Meteor. Monographs, Vol. 24, 165-170.
+!!
+!! AUTHOR
+!! ------
+!! P. BECHTOLD * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 26/03/96
+!! Peter Bechtold 15/11/96 replace theta_il by enthalpy
+!! " 10/12/98 changes for ARPEGE
+!! " 01/01/02 Apply conservation correction
+!! F Bouyssel 05/11/08 Modifications for reproductibility
+!! E. Bazile 20/07/09 Input of TKECLS.
+!! Juan 24/09/2012: for BUG Pgi rewrite PACK function on mode_pack_pgi
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_CST
+ USE MODD_CONVPAREXT
+ USE MODD_CONVPAR_SHAL
+!USE MODD_NSV, ONLY : NSV_LGBEG,NSV_LGEND
+!
+ USE MODI_CONVECT_TRIGGER_SHAL
+ USE MODI_CONVECT_UPDRAFT_SHAL
+ USE MODI_CONVECT_CLOSURE_SHAL
+!USE MODI_CONVECT_CHEM_TRANSPORT
+!
+!SeBi #ifdef MNH_PGI
+!SeBi USE MODE_PACK_PGI
+!SeBi #endif
+!
+ implicit none
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+ INTEGER, INTENT(IN) :: KLON ! horizontal dimension
+ INTEGER, INTENT(IN) :: KLEV ! vertical dimension
+ INTEGER, INTENT(IN) :: KIDIA ! value of the first point in x
+ INTEGER, INTENT(IN) :: KFDIA ! value of the last point in x
+ INTEGER, INTENT(IN) :: KBDIA ! vertical computations start at
+! ! KBDIA that is at least 1
+ INTEGER, INTENT(IN) :: KTDIA ! vertical computations can be
+ ! limited to KLEV + 1 - KTDIA
+ ! default=1
+ REAL, INTENT(IN) :: PDTCONV ! Interval of time between two
+ ! calls of the deep convection
+ ! scheme
+ INTEGER, INTENT(IN) :: KICE ! flag for ice ( 1 = yes,
+ ! 0 = no ice )
+ LOGICAL, INTENT(IN) :: OSETTADJ ! logical to set convective
+ ! adjustment time by user
+ REAL, INTENT(IN) :: PTADJS ! user defined adjustment time
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PTT ! grid scale temperature at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRVT ! grid scale water vapor "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRCT ! grid scale r_c "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PRIT ! grid scale r_i "
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PWT ! grid scale vertical
+ ! velocity (m/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PPABST ! grid scale pressure at t
+ REAL, DIMENSION(KLON, KLEV), INTENT(IN) :: PZZ ! height of model layer (m)
+ REAL, DIMENSION(KLON), INTENT(IN) :: PTKECLS ! TKE in the CLS (m2/s2)
+!
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PTTEN ! convective temperature
+ ! tendency (K/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRVTEN ! convective r_v tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRCTEN ! convective r_c tendency (1/s)
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PRITEN ! convective r_i tendency (1/s)
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLTOP ! cloud top level
+ INTEGER, DIMENSION(KLON), INTENT(INOUT):: KCLBAS ! cloud base level
+ ! they are given a value of
+ ! 0 if no convection
+ REAL, DIMENSION(KLON, KLEV), INTENT(INOUT):: PUMF ! updraft mass flux (kg/s m2)
+!
+ LOGICAL, INTENT(IN) :: OCH1CONV ! include tracer transport
+ INTEGER, INTENT(IN) :: KCH1 ! number of species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(IN) :: PCH1! grid scale chemical species
+ REAL, DIMENSION(KLON, KLEV, KCH1), INTENT(INOUT):: PCH1TEN! species conv. tendency (1/s)
+!
+!
+!* 0.2 Declarations of local fixed memory variables :
+!
+ INTEGER :: ITEST, ICONV ! number of convective columns
+ INTEGER :: IIB, IIE ! horizontal loop bounds
+ INTEGER :: IKB, IKE ! vertical loop bounds
+ INTEGER :: IKS ! vertical dimension
+ INTEGER :: JI, JL ! horizontal loop index
+ INTEGER :: JN ! number of tracers
+ INTEGER :: JK, JKM, JKP ! vertical loop index
+ INTEGER :: IFTSTEPS ! only used for chemical tracers
+ real :: ZEPS, ZEPSA ! R_d / R_v, R_v / R_d
+ real :: ZRDOCP ! R_d/C_p
+!
+ LOGICAL, DIMENSION(KLON, KLEV) :: GTRIG3 ! 3D logical mask for convection
+ LOGICAL, DIMENSION(KLON) :: GTRIG ! 2D logical mask for trigger test
+ REAL, DIMENSION(KLON, KLEV) :: ZTHT, ZSTHV, ZSTHES ! grid scale theta, theta_v
+ REAL, DIMENSION(KLON) :: ZWORK2, ZWORK2B ! work array
+ real :: ZW1 ! work variable
+!
+!
+!* 0.2 Declarations of local allocatable variables :
+!
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IDPL ! index for parcel departure level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IPBL ! index for source layer top
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ILCL ! index for lifting condensation level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IETL ! index for zero buoyancy level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ICTL ! index for cloud top level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ILFS ! index for level of free sink
+!
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ISDPL ! index for parcel departure level
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ISPBL ! index for source layer top
+ INTEGER, DIMENSION(:), ALLOCATABLE :: ISLCL ! index for lifting condensation level
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSTHLCL ! updraft theta at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSTLCL ! updraft temp. at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSRVLCL ! updraft rv at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSWLCL ! updraft w at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSZLCL ! LCL height
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSTHVELCL! envir. theta_v at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZSDXDY ! grid area (m^2)
+!
+! grid scale variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZZ ! height of model layer (m)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZPRES ! grid scale pressure
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDPRES ! pressure difference between
+ ! bottom and top of layer (Pa)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZW ! grid scale vertical velocity on theta grid
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTT ! temperature
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTH ! grid scale theta
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHV ! grid scale theta_v
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHL ! grid scale enthalpy (J/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHES, ZTHEST ! grid scale saturated theta_e
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRW ! grid scale total water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRV ! grid scale water vapor (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRC ! grid scale cloud water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRI ! grid scale cloud ice (kg/kg)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZDXDY ! grid area (m^2)
+!
+! updraft variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUMF ! updraft mass flux (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUER ! updraft entrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUDR ! updraft detrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUTHL ! updraft enthalpy (J/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZUTHV ! updraft theta_v (K)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURW ! updraft total water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURC ! updraft cloud water (kg/kg)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZURI ! updraft cloud ice (kg/kg)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZMFLCL ! cloud base unit mass flux(kg/s)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZCAPE ! available potent. energy
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTHLCL ! updraft theta at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTLCL ! updraft temp. at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZRVLCL ! updraft rv at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZWLCL ! updraft w at LCL
+ REAL, DIMENSION(:), ALLOCATABLE :: ZZLCL ! LCL height
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTHVELCL! envir. theta_v at LCL
+!
+! downdraft variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDMF ! downdraft mass flux (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDER ! downdraft entrainment (kg/s)
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZDDR ! downdraft detrainment (kg/s)
+!
+! closure variables
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZLMASS ! mass of model layer (kg)
+ REAL, DIMENSION(:), ALLOCATABLE :: ZTIMEC ! advective time period
+!
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZTHC ! conv. adj. grid scale theta
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRVC ! conv. adj. grid scale r_w
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRCC ! conv. adj. grid scale r_c
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZRIC ! conv. adj. grid scale r_i
+ REAL, DIMENSION(:, :), ALLOCATABLE :: ZWSUB ! envir. compensating subsidence (Pa/s)
+!
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: GTRIG1 ! logical mask for convection
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: GWORK ! logical work array
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IINDEX, IJINDEX, IJSINDEX, IJPINDEX!hor.index
+ REAL, DIMENSION(:), ALLOCATABLE :: ZCPH ! specific heat C_ph
+ REAL, DIMENSION(:), ALLOCATABLE :: ZLV, ZLS! latent heat of vaporis., sublim.
+ real :: ZES ! saturation vapor mixng ratio
+!
+! Chemical Tracers:
+ REAL, DIMENSION(:, :, :), ALLOCATABLE:: ZCH1 ! grid scale chemical specy (kg/kg)
+ REAL, DIMENSION(:, :, :), ALLOCATABLE:: ZCH1C ! conv. adjust. chemical specy 1
+ REAL, DIMENSION(:, :), ALLOCATABLE:: ZWORK3 ! conv. adjust. chemical specy 1
+ LOGICAL, DIMENSION(:, :, :), ALLOCATABLE::GTRIG4 ! logical mask
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 0.3 Compute loop bounds
+! -------------------
+!
+ IIB = KIDIA
+ IIE = KFDIA
+ JCVEXB = MAX(0, KBDIA - 1)
+ IKB = 1 + JCVEXB
+ IKS = KLEV
+ JCVEXT = MAX(0, KTDIA - 1)
+ IKE = IKS - JCVEXT
+!
+!
+!* 0.5 Update convective counter ( where KCOUNT > 0
+! convection is still active ).
+! ---------------------------------------------
+!
+ GTRIG(:) = .false.
+ GTRIG(IIB:IIE) = .true.
+ ITEST = COUNT(GTRIG(:))
+ if(ITEST == 0) then
+ RETURN
+ endif
+
+!
+!
+!* 0.7 Reset convective tendencies to zero if convective
+! counter becomes negative
+! -------------------------------------------------
+!
+ GTRIG3(:, :) = SPREAD(GTRIG(:), DIM=2, NCOPIES=IKS)
+ WHERE(GTRIG3(:, :))
+ PTTEN(:, :) = 0.
+ PRVTEN(:, :) = 0.
+ PRCTEN(:, :) = 0.
+ PRITEN(:, :) = 0.
+! PUTEN(:,:) = 0.
+! PVTEN(:,:) = 0.
+ PUMF(:, :) = 0.
+ ENDWHERE
+ WHERE(GTRIG(:))
+ KCLTOP(:) = 0
+ KCLBAS(:) = 0
+ ENDWHERE
+ if(OCH1CONV) then
+ ALLOCATE(GTRIG4(KLON, KLEV, KCH1))
+ GTRIG4(:, :, :) = SPREAD(GTRIG3(:, :), DIM=3, NCOPIES=KCH1)
+ WHERE(GTRIG4(:, :, :)) PCH1TEN(:, :, :) = 0.
+ DEALLOCATE(GTRIG4)
+ endif
+!
+!
+!* 1. Initialize local variables
+! ----------------------------
+!
+ ZEPS = XRD / XRV
+ ZEPSA = XRV / XRD
+ ZRDOCP = XRD / XCPD
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.1 Set up grid scale theta, theta_v, theta_es
+! ------------------------------------------
+!
+ ZTHT(:, :) = 300.
+ ZSTHV(:, :) = 300.
+ ZSTHES(:, :) = 400.
+ do JK = IKB, IKE
+ do JI = IIB, IIE
+ if(PPABST(JI, JK) > 40.E2) then
+ ZTHT(JI, JK) = PTT(JI, JK) * (XP00 / PPABST(JI, JK))**ZRDOCP
+ ZSTHV(JI, JK) = ZTHT(JI, JK) * (1.+ZEPSA * PRVT(JI, JK)) / &
+ (1.+PRVT(JI, JK) + PRCT(JI, JK) + PRIT(JI, JK))
+!
+ ! use conservative Bolton (1980) formula for theta_e
+ ! it is used to compute CAPE for undilute parcel ascent
+ ! For economical reasons we do not use routine CONVECT_SATMIXRATIO here
+!
+ ZES = EXP(XALPW - XBETAW / PTT(JI, JK) - XGAMW * LOG(PTT(JI, JK)))
+ ZES = MIN(1., ZEPS * ZES / (PPABST(JI, JK) - ZES))
+ ZSTHES(JI, JK) = PTT(JI, JK) * (ZTHT(JI, JK) / PTT(JI, JK))** &
+ (1.-0.28 * ZES) * EXP((3374.6525 / PTT(JI, JK) - 2.5403) &
+ * ZES * (1.+0.81 * ZES))
+ endif
+ enddo
+ enddo
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. Test for convective columns and determine properties at the LCL
+! --------------------------------------------------------------
+!
+!* 2.1 Allocate arrays depending on number of model columns that need
+! to be tested for convection (i.e. where no convection is present
+! at the moment.
+! --------------------------------------------------------------
+!
+ ALLOCATE(ZPRES(ITEST, IKS))
+ ALLOCATE(ZZ(ITEST, IKS))
+ ALLOCATE(ZW(ITEST, IKS))
+ ALLOCATE(ZTH(ITEST, IKS))
+ ALLOCATE(ZTHV(ITEST, IKS))
+ ALLOCATE(ZTHEST(ITEST, IKS))
+ ALLOCATE(ZRV(ITEST, IKS))
+ ALLOCATE(ZSTHLCL(ITEST))
+ ALLOCATE(ZSTLCL(ITEST))
+ ALLOCATE(ZSRVLCL(ITEST))
+ ALLOCATE(ZSWLCL(ITEST))
+ ALLOCATE(ZSZLCL(ITEST))
+ ALLOCATE(ZSTHVELCL(ITEST))
+ ALLOCATE(ISDPL(ITEST))
+ ALLOCATE(ISPBL(ITEST))
+ ALLOCATE(ISLCL(ITEST))
+ ALLOCATE(ZSDXDY(ITEST))
+ ALLOCATE(GTRIG1(ITEST))
+ ALLOCATE(IINDEX(KLON))
+ ALLOCATE(IJSINDEX(ITEST))
+ do JI = 1, KLON
+ IINDEX(JI) = JI
+ enddo
+ IJSINDEX(:) = PACK(IINDEX(:), MASK=GTRIG(:))
+!
+ do JK = IKB, IKE
+ do JI = 1, ITEST
+ JL = IJSINDEX(JI)
+ ZPRES(JI, JK) = PPABST(JL, JK)
+ ZZ(JI, JK) = PZZ(JL, JK)
+ ZTH(JI, JK) = ZTHT(JL, JK)
+ ZTHV(JI, JK) = ZSTHV(JL, JK)
+ ZTHEST(JI, JK) = ZSTHES(JL, JK)
+ ZRV(JI, JK) = MAX(0., PRVT(JL, JK))
+ ZW(JI, JK) = PWT(JL, JK)
+ enddo
+ enddo
+ do JI = 1, ITEST
+ JL = IJSINDEX(JI)
+ ZSDXDY(JI) = XA25
+ enddo
+!
+!* 2.2 Compute environm. enthalpy and total water = r_v + r_i + r_c
+! and envir. saturation theta_e
+! ------------------------------------------------------------
+!
+!
+!* 2.3 Test for convective columns and determine properties at the LCL
+! --------------------------------------------------------------
+!
+ ISLCL(:) = MAX(IKB, 2) ! initialize DPL PBL and LCL
+ ISDPL(:) = IKB
+ ISPBL(:) = IKB
+!
+ call CONVECT_TRIGGER_SHAL(ITEST, KLEV, &
+ ZPRES, ZTH, ZTHV, ZTHEST, &
+ ZRV, ZW, ZZ, ZSDXDY, PTKECLS, &
+ ZSTHLCL, ZSTLCL, ZSRVLCL, ZSWLCL, ZSZLCL, &
+ ZSTHVELCL, ISLCL, ISDPL, ISPBL, GTRIG1)
+!
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZZ)
+ DEALLOCATE(ZTH)
+ DEALLOCATE(ZTHV)
+ DEALLOCATE(ZTHEST)
+ DEALLOCATE(ZRV)
+ DEALLOCATE(ZW)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. After the call of TRIGGER_FUNCT we allocate all the dynamic
+! arrays used in the convection scheme using the mask GTRIG, i.e.
+! we do calculus only in convective columns. This corresponds to
+! a GATHER operation.
+! --------------------------------------------------------------
+!
+ ICONV = COUNT(GTRIG1(:))
+ if(ICONV == 0) then
+ DEALLOCATE(ZSTHLCL)
+ DEALLOCATE(ZSTLCL)
+ DEALLOCATE(ZSRVLCL)
+ DEALLOCATE(ZSWLCL)
+ DEALLOCATE(ZSZLCL)
+ DEALLOCATE(ZSTHVELCL)
+ DEALLOCATE(ZSDXDY)
+ DEALLOCATE(ISLCL)
+ DEALLOCATE(ISDPL)
+ DEALLOCATE(ISPBL)
+ DEALLOCATE(GTRIG1)
+ DEALLOCATE(IINDEX)
+ DEALLOCATE(IJSINDEX)
+ RETURN ! no convective column has been found, exit DEEP_CONVECTION
+ endif
+!
+ ! vertical index variables
+!
+ ALLOCATE(IDPL(ICONV))
+ ALLOCATE(IPBL(ICONV))
+ ALLOCATE(ILCL(ICONV))
+ ALLOCATE(ICTL(ICONV))
+ ALLOCATE(IETL(ICONV))
+!
+ ! grid scale variables
+!
+ ALLOCATE(ZZ(ICONV, IKS)); ZZ = 0.0
+ ALLOCATE(ZPRES(ICONV, IKS)); ZPRES = 0.0
+ ALLOCATE(ZDPRES(ICONV, IKS)); ZDPRES = 0.0
+ ALLOCATE(ZTT(ICONV, IKS)); ZTT = 0.0
+ ALLOCATE(ZTH(ICONV, IKS)); ZTH = 0.0
+ ALLOCATE(ZTHV(ICONV, IKS)); ZTHV = 0.0
+ ALLOCATE(ZTHL(ICONV, IKS)); ZTHL = 0.0
+ ALLOCATE(ZTHES(ICONV, IKS)); ZTHES = 0.0
+ ALLOCATE(ZRV(ICONV, IKS)); ZRV = 0.0
+ ALLOCATE(ZRC(ICONV, IKS)); ZRC = 0.0
+ ALLOCATE(ZRI(ICONV, IKS)); ZRI = 0.0
+ ALLOCATE(ZRW(ICONV, IKS)); ZRW = 0.0
+ ALLOCATE(ZDXDY(ICONV)); ZDXDY = 0.0
+!
+ ! updraft variables
+!
+ ALLOCATE(ZUMF(ICONV, IKS))
+ ALLOCATE(ZUER(ICONV, IKS))
+ ALLOCATE(ZUDR(ICONV, IKS))
+ ALLOCATE(ZUTHL(ICONV, IKS))
+ ALLOCATE(ZUTHV(ICONV, IKS))
+ ALLOCATE(ZURW(ICONV, IKS))
+ ALLOCATE(ZURC(ICONV, IKS))
+ ALLOCATE(ZURI(ICONV, IKS))
+ ALLOCATE(ZTHLCL(ICONV))
+ ALLOCATE(ZTLCL(ICONV))
+ ALLOCATE(ZRVLCL(ICONV))
+ ALLOCATE(ZWLCL(ICONV))
+ ALLOCATE(ZMFLCL(ICONV))
+ ALLOCATE(ZZLCL(ICONV))
+ ALLOCATE(ZTHVELCL(ICONV))
+ ALLOCATE(ZCAPE(ICONV))
+!
+ ! work variables
+!
+ ALLOCATE(IJINDEX(ICONV))
+ ALLOCATE(IJPINDEX(ICONV))
+ ALLOCATE(ZCPH(ICONV))
+ ALLOCATE(ZLV(ICONV))
+ ALLOCATE(ZLS(ICONV))
+!
+!
+!* 3.1 Gather grid scale and updraft base variables in
+! arrays using mask GTRIG
+! ---------------------------------------------------
+!
+ GTRIG(:) = UNPACK(GTRIG1(:), MASK=GTRIG, FIELD=.false.)
+ IJINDEX(:) = PACK(IINDEX(:), MASK=GTRIG(:))
+!
+ do JK = IKB, IKE
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ ZZ(JI, JK) = PZZ(JL, JK)
+ ZPRES(JI, JK) = PPABST(JL, JK)
+ ZTT(JI, JK) = PTT(JL, JK)
+ ZTH(JI, JK) = ZTHT(JL, JK)
+ ZTHES(JI, JK) = ZSTHES(JL, JK)
+ ZRV(JI, JK) = MAX(0., PRVT(JL, JK))
+ ZRC(JI, JK) = MAX(0., PRCT(JL, JK))
+ ZRI(JI, JK) = MAX(0., PRIT(JL, JK))
+ ZTHV(JI, JK) = ZSTHV(JL, JK)
+ enddo
+ enddo
+!
+ do JI = 1, ITEST
+ IJSINDEX(JI) = JI
+ enddo
+ IJPINDEX(:) = PACK(IJSINDEX(:), MASK=GTRIG1(:))
+ do JI = 1, ICONV
+ JL = IJPINDEX(JI)
+ IDPL(JI) = ISDPL(JL)
+ IPBL(JI) = ISPBL(JL)
+ ILCL(JI) = ISLCL(JL)
+ ZTHLCL(JI) = ZSTHLCL(JL)
+ ZTLCL(JI) = ZSTLCL(JL)
+ ZRVLCL(JI) = ZSRVLCL(JL)
+ ZWLCL(JI) = ZSWLCL(JL)
+ ZZLCL(JI) = ZSZLCL(JL)
+ ZTHVELCL(JI) = ZSTHVELCL(JL)
+ ZDXDY(JI) = ZSDXDY(JL)
+ enddo
+ ALLOCATE(GWORK(ICONV))
+ GWORK(:) = PACK(GTRIG1(:), MASK=GTRIG1(:))
+ DEALLOCATE(GTRIG1)
+ ALLOCATE(GTRIG1(ICONV))
+ GTRIG1(:) = GWORK(:)
+!
+ DEALLOCATE(GWORK)
+ DEALLOCATE(IJPINDEX)
+ DEALLOCATE(ISDPL)
+ DEALLOCATE(ISPBL)
+ DEALLOCATE(ISLCL)
+ DEALLOCATE(ZSTHLCL)
+ DEALLOCATE(ZSTLCL)
+ DEALLOCATE(ZSRVLCL)
+ DEALLOCATE(ZSWLCL)
+ DEALLOCATE(ZSZLCL)
+ DEALLOCATE(ZSTHVELCL)
+ DEALLOCATE(ZSDXDY)
+!
+!
+!* 3.2 Compute pressure difference
+! ---------------------------------------------------
+!
+ ZDPRES(:, IKB) = 0.
+ do JK = IKB + 1, IKE
+ ZDPRES(:, JK) = ZPRES(:, JK - 1) - ZPRES(:, JK)
+ enddo
+!
+!* 3.3 Compute environm. enthalpy and total water = r_v + r_i + r_c
+! ----------------------------------------------------------
+!
+ do JK = IKB, IKE, 1
+ ZRW(:, JK) = ZRV(:, JK) + ZRC(:, JK) + ZRI(:, JK)
+ ZCPH(:) = XCPD + XCPV * ZRW(:, JK)
+ ZLV(:) = XLVTT + (XCPV - XCL) * (ZTT(:, JK) - XTT) ! compute L_v
+ ZLS(:) = XLSTT + (XCPV - XCI) * (ZTT(:, JK) - XTT) ! compute L_i
+ ZTHL(:, JK) = ZCPH(:) * ZTT(:, JK) + (1.+ZRW(:, JK)) * XG * ZZ(:, JK) &
+ - ZLV(:) * ZRC(:, JK) - ZLS(:) * ZRI(:, JK)
+ enddo
+!
+ DEALLOCATE(ZCPH)
+ DEALLOCATE(ZLV)
+ DEALLOCATE(ZLS)
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. Compute updraft properties
+! ----------------------------
+!
+!* 4.1 Set mass flux at LCL ( here a unit mass flux with w = 1 m/s )
+! -------------------------------------------------------------
+!
+ ZDXDY(:) = XA25
+ ZMFLCL(:) = XA25 * 1.E-3
+!
+!
+!
+ call CONVECT_UPDRAFT_SHAL(ICONV, KLEV, &
+ KICE, ZPRES, ZDPRES, ZZ, ZTHL, ZTHV, ZTHES, ZRW, &
+ ZTHLCL, ZTLCL, ZRVLCL, ZWLCL, ZZLCL, ZTHVELCL, &
+ ZMFLCL, GTRIG1, ILCL, IDPL, IPBL, &
+ ZUMF, ZUER, ZUDR, ZUTHL, ZUTHV, ZURW, &
+ ZURC, ZURI, ZCAPE, ICTL, IETL)
+!
+!
+!
+!* 4.2 In routine UPDRAFT GTRIG1 has been set to false when cloud
+! thickness is smaller than 3 km
+! -----------------------------------------------------------
+!
+!
+!
+!* 4.3 Allocate memory for downdraft variables
+! ---------------------------------------
+!
+! downdraft variables
+!
+ ALLOCATE(ZDMF(ICONV, IKS))
+ ALLOCATE(ZDER(ICONV, IKS))
+ ALLOCATE(ZDDR(ICONV, IKS))
+ ALLOCATE(ILFS(ICONV))
+ ALLOCATE(ZLMASS(ICONV, IKS))
+ ZDMF(:, :) = 0.
+ ZDER(:, :) = 0.
+ ZDDR(:, :) = 0.
+ ILFS(:) = IKB
+ do JK = IKB, IKE
+ ZLMASS(:, JK) = ZDXDY(:) * ZDPRES(:, JK) / XG ! mass of model layer
+ enddo
+ ZLMASS(:, IKB) = ZLMASS(:, IKB + 1)
+!
+! closure variables
+!
+ ALLOCATE(ZTIMEC(ICONV))
+ ALLOCATE(ZTHC(ICONV, IKS))
+ ALLOCATE(ZRVC(ICONV, IKS))
+ ALLOCATE(ZRCC(ICONV, IKS))
+ ALLOCATE(ZRIC(ICONV, IKS))
+ ALLOCATE(ZWSUB(ICONV, IKS))
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. Compute downdraft properties
+! ----------------------------
+!
+ ZTIMEC(:) = XCTIME_SHAL
+ if(OSETTADJ) ZTIMEC(:) = PTADJS
+!
+!* 7. Determine adjusted environmental values assuming
+! that all available buoyant energy must be removed
+! within an advective time step ZTIMEC.
+! ---------------------------------------------------
+!
+ call CONVECT_CLOSURE_SHAL(ICONV, KLEV, &
+ ZPRES, ZDPRES, ZZ, ZDXDY, ZLMASS, &
+ ZTHL, ZTH, ZRW, ZRC, ZRI, GTRIG1, &
+ ZTHC, ZRVC, ZRCC, ZRIC, ZWSUB, &
+ ILCL, IDPL, IPBL, ICTL, &
+ ZUMF, ZUER, ZUDR, ZUTHL, ZURW, &
+ ZURC, ZURI, ZCAPE, ZTIMEC, IFTSTEPS)
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. Determine the final grid-scale (environmental) convective
+! tendencies and set convective counter
+! --------------------------------------------------------
+!
+!
+!* 8.1 Grid scale tendencies
+! ---------------------
+!
+ ! in order to save memory, the tendencies are temporarily stored
+ ! in the tables for the adjusted grid-scale values
+!
+ do JK = IKB, IKE
+ ZTHC(:, JK) = (ZTHC(:, JK) - ZTH(:, JK)) / ZTIMEC(:) &
+ * (ZPRES(:, JK) / XP00)**ZRDOCP ! change theta in temperature
+ ZRVC(:, JK) = (ZRVC(:, JK) - ZRW(:, JK) + ZRC(:, JK) + ZRI(:, JK)) &
+ / ZTIMEC(:)
+
+ ZRCC(:, JK) = (ZRCC(:, JK) - ZRC(:, JK)) / ZTIMEC(:)
+ ZRIC(:, JK) = (ZRIC(:, JK) - ZRI(:, JK)) / ZTIMEC(:)
+!
+ enddo
+!
+!
+!* 8.2 Apply conservation correction
+! -----------------------------
+!
+ ! adjustment at cloud top to smooth possible discontinuous profiles at PBL inversions
+ ! (+ - - tendencies for moisture )
+!
+!
+ if(LLSMOOTH) then
+ do JI = 1, ICONV
+ JK = ICTL(JI)
+ JKM = MAX(2, ICTL(JI) - 1)
+ JKP = MAX(2, ICTL(JI) - 2)
+ ZRVC(JI, JKM) = ZRVC(JI, JKM) + .5 * ZRVC(JI, JK)
+ ZRCC(JI, JKM) = ZRCC(JI, JKM) + .5 * ZRCC(JI, JK)
+ ZRIC(JI, JKM) = ZRIC(JI, JKM) + .5 * ZRIC(JI, JK)
+ ZTHC(JI, JKM) = ZTHC(JI, JKM) + .5 * ZTHC(JI, JK)
+ ZRVC(JI, JKP) = ZRVC(JI, JKP) + .3 * ZRVC(JI, JK)
+ ZRCC(JI, JKP) = ZRCC(JI, JKP) + .3 * ZRCC(JI, JK)
+ ZRIC(JI, JKP) = ZRIC(JI, JKP) + .3 * ZRIC(JI, JK)
+ ZTHC(JI, JKP) = ZTHC(JI, JKP) + .3 * ZTHC(JI, JK)
+ ZRVC(JI, JK) = .2 * ZRVC(JI, JK)
+ ZRCC(JI, JK) = .2 * ZRCC(JI, JK)
+ ZRIC(JI, JK) = .2 * ZRIC(JI, JK)
+ ZTHC(JI, JK) = .2 * ZTHC(JI, JK)
+ enddo
+ endif
+!
+!
+ ! Compute vertical integrals - Fluxes
+!
+ JKM = MAXVAL(ICTL(:))
+ ZWORK2(:) = 0.
+ ZWORK2B(:) = 0.
+ do JK = IKB + 1, JKM
+ JKP = JK + 1
+ do JI = 1, ICONV
+ if(JK <= ICTL(JI)) then
+ ZW1 = ZRVC(JI, JK) + ZRCC(JI, JK) + ZRIC(JI, JK)
+ ZWORK2(JI) = ZWORK2(JI) + ZW1* & ! moisture
+ .5 * (ZPRES(JI, JK - 1) - ZPRES(JI, JKP)) / XG
+ ZW1 = (XCPD + XCPV * ZRW(JI, JK)) * ZTHC(JI, JK) - &
+ (XLVTT + (XCPV - XCL) * (ZTT(JI, JK) - XTT)) * ZRCC(JI, JK) - &
+ (XLSTT + (XCPV - XCL) * (ZTT(JI, JK) - XTT)) * ZRIC(JI, JK)
+ ZWORK2B(JI) = ZWORK2B(JI) + ZW1* & ! energy
+ .5 * (ZPRES(JI, JK - 1) - ZPRES(JI, JKP)) / XG
+ endif
+ enddo
+ enddo
+!
+ ! Budget error (integral must be zero)
+!
+ do JI = 1, ICONV
+ if(ICTL(JI) > IKB + 1) then
+ JKP = ICTL(JI)
+ ZW1 = XG / (ZPRES(JI, IKB) - ZPRES(JI, JKP) - &
+ .5 * (ZDPRES(JI, IKB + 1) - ZDPRES(JI, JKP + 1)))
+ ZWORK2(JI) = ZWORK2(JI) * ZW1
+ ZWORK2B(JI) = ZWORK2B(JI) * ZW1
+ endif
+ enddo
+!
+ ! Apply uniform correction
+!
+ do JK = JKM, IKB + 1, -1
+ do JI = 1, ICONV
+ if(ICTL(JI) > IKB + 1 .and. JK <= ICTL(JI)) then
+ ! ZW1 = ABS(ZRVC(JI,JK)) + ABS(ZRCC(JI,JK)) + ABS(ZRIC(JI,JK)) + 1.E-12
+ ! ZRVC(JI,JK) = ZRVC(JI,JK) - ABS(ZRVC(JI,JK))/ZW1*ZWORK2(JI) ! moisture
+ ZRVC(JI, JK) = ZRVC(JI, JK) - ZWORK2(JI) ! moisture
+ ! ZRCC(JI,JK) = ZRCC(JI,JK) - ABS(ZRCC(JI,JK))/ZW1*ZWORK2(JI)
+ ! ZRIC(JI,JK) = ZRIC(JI,JK) - ABS(ZRIC(JI,JK))/ZW1*ZWORK2(JI)
+ ZTHC(JI, JK) = ZTHC(JI, JK) - ZWORK2B(JI) / XCPD ! enthalpy
+ endif
+ enddo
+ enddo
+!
+ ! execute a "scatter"= pack command to store the tendencies in
+ ! the final 2D tables
+!
+ do JK = IKB, IKE
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ PTTEN(JL, JK) = ZTHC(JI, JK)
+ PRVTEN(JL, JK) = ZRVC(JI, JK)
+ PRCTEN(JL, JK) = ZRCC(JI, JK)
+ PRITEN(JL, JK) = ZRIC(JI, JK)
+ enddo
+ enddo
+!
+!
+! Cloud base and top levels
+! -------------------------
+!
+ ILCL(:) = MIN(ILCL(:), ICTL(:))
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ KCLTOP(JL) = ICTL(JI)
+ KCLBAS(JL) = ILCL(JI)
+ enddo
+!
+!
+!* 8.7 Compute convective tendencies for Tracers
+! ------------------------------------------
+!
+! if ( OCH1CONV ) then
+!!
+! ALLOCATE( ZCH1(ICONV,IKS,KCH1) )
+! ALLOCATE( ZCH1C(ICONV,IKS,KCH1) )
+! ALLOCATE( ZWORK3(ICONV,KCH1) )
+!!
+! do JK = IKB, IKE
+! do JI = 1, ICONV
+! JL = IJINDEX(JI)
+! ZCH1(JI,JK,:) = PCH1(JL,JK,:)
+! end do
+! end do
+!!
+! call CONVECT_CHEM_TRANSPORT( ICONV, KLEV, KCH1, ZCH1, ZCH1C, &
+! IDPL, IPBL, ILCL, ICTL, ILFS, ILFS, &
+! ZUMF, ZUER, ZUDR, ZDMF, ZDER, ZDDR, &
+! ZTIMEC, ZDXDY, ZDMF(:,1), ZLMASS, ZWSUB, &
+! IFTSTEPS )
+!!
+!!
+!!* 8.8 Apply conservation correction
+!! -----------------------------
+!!
+! ! Compute vertical integrals
+!!
+! JKM = MAXVAL( ICTL(:) )
+! do JN = 1, KCH1
+! if(JN < NSV_LGBEG .OR. JN>NSV_LGEND-1) then ! no correction for xy lagrangian variables
+! ZWORK3(:,JN) = 0.
+! ZWORK2(:) = 0.
+! do JK = IKB+1, JKM
+! JKP = JK + 1
+! do JI = 1, ICONV
+! ZW1 = .5 * (ZPRES(JI,JK-1) - ZPRES(JI,JKP))
+! ZWORK3(JI,JN) = ZWORK3(JI,JN) + (ZCH1C(JI,JK,JN)-ZCH1(JI,JK,JN)) * ZW1
+! ZWORK2(JI) = ZWORK2(JI) + ABS(ZCH1C(JI,JK,JN)) * ZW1
+! end do
+! end do
+!!
+! ! Apply concentration weighted correction
+!!
+! do JK = JKM, IKB+1, -1
+! do JI = 1, ICONV
+! if ( ICTL(JI) > IKB+1 .and. JK <= ICTL(JI) ) then
+! ZCH1C(JI,JK,JN) = ZCH1C(JI,JK,JN) - &
+! ZWORK3(JI,JN)*ABS(ZCH1C(JI,JK,JN))/MAX(1.E-30,ZWORK2(JI))
+! end if
+! end do
+! end do
+! end if
+!!
+! do JK = IKB, IKE
+! do JI = 1, ICONV
+! JL = IJINDEX(JI)
+! PCH1TEN(JL,JK,JN) = (ZCH1C(JI,JK,JN)-ZCH1(JI,JK,JN) ) / ZTIMEC(JI)
+! end do
+! end do
+! end do
+! end if
+!
+!-------------------------------------------------------------------------------
+!
+!* 9. Write up- and downdraft mass fluxes
+! ------------------------------------
+!
+ do JK = IKB, IKE
+ ZUMF(:, JK) = ZUMF(:, JK) / ZDXDY(:) ! Mass flux per unit area
+ enddo
+ ZWORK2(:) = 1.
+ do JK = IKB, IKE
+ do JI = 1, ICONV
+ JL = IJINDEX(JI)
+ if(KCLTOP(JL) <= IKB + 1) ZWORK2(JL) = 0.
+ PUMF(JL, JK) = ZUMF(JI, JK) * ZWORK2(JL)
+ enddo
+ enddo
+!
+!-------------------------------------------------------------------------------
+!
+!* 10. Deallocate all local arrays
+! ---------------------------
+!
+! downdraft variables
+!
+ DEALLOCATE(ZDMF)
+ DEALLOCATE(ZDER)
+ DEALLOCATE(ZDDR)
+ DEALLOCATE(ILFS)
+ DEALLOCATE(ZLMASS)
+!
+! closure variables
+!
+ DEALLOCATE(ZTIMEC)
+ DEALLOCATE(ZTHC)
+ DEALLOCATE(ZRVC)
+ DEALLOCATE(ZRCC)
+ DEALLOCATE(ZRIC)
+ DEALLOCATE(ZWSUB)
+!
+ if(OCH1CONV) then
+ DEALLOCATE(ZCH1)
+ DEALLOCATE(ZCH1C)
+ DEALLOCATE(ZWORK3)
+ endif
+!
+! vertical index
+!
+ DEALLOCATE(IDPL)
+ DEALLOCATE(IPBL)
+ DEALLOCATE(ILCL)
+ DEALLOCATE(ICTL)
+ DEALLOCATE(IETL)
+!
+! grid scale variables
+!
+ DEALLOCATE(ZZ)
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZDPRES)
+ DEALLOCATE(ZTT)
+ DEALLOCATE(ZTH)
+ DEALLOCATE(ZTHV)
+ DEALLOCATE(ZTHL)
+ DEALLOCATE(ZTHES)
+ DEALLOCATE(ZRW)
+ DEALLOCATE(ZRV)
+ DEALLOCATE(ZRC)
+ DEALLOCATE(ZRI)
+ DEALLOCATE(ZDXDY)
+!
+! updraft variables
+!
+ DEALLOCATE(ZUMF)
+ DEALLOCATE(ZUER)
+ DEALLOCATE(ZUDR)
+ DEALLOCATE(ZUTHL)
+ DEALLOCATE(ZUTHV)
+ DEALLOCATE(ZURW)
+ DEALLOCATE(ZURC)
+ DEALLOCATE(ZURI)
+ DEALLOCATE(ZTHLCL)
+ DEALLOCATE(ZTLCL)
+ DEALLOCATE(ZRVLCL)
+ DEALLOCATE(ZWLCL)
+ DEALLOCATE(ZZLCL)
+ DEALLOCATE(ZTHVELCL)
+ DEALLOCATE(ZMFLCL)
+ DEALLOCATE(ZCAPE)
+!
+! work arrays
+!
+ DEALLOCATE(IINDEX)
+ DEALLOCATE(IJINDEX)
+ DEALLOCATE(IJSINDEX)
+ DEALLOCATE(GTRIG1)
+!
+!
+ENDsubroutine SHALLOW_CONVECTION
+
+! /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
+! **************************************************************************************************
+! \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
+
diff --git a/MAR/code_mar/dynadv_dlf.f90 b/MAR/code_mar/dynadv_dlf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5bfebeecab6743b823ec240b49afbb7c6732bef0
--- /dev/null
+++ b/MAR/code_mar/dynadv_dlf.f90
@@ -0,0 +1,176 @@
+subroutine DYNadv_dLF_mp(nordAV, ffx, ffy, advffx, advffy)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FAST 07-04-2021 MAR |
+ ! | subroutine DYNadv_dLF generates Advection Contribution |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT/ ffx(mx,my,mz): Advected Variable |
+ ! | ^^^^^^ |
+ ! | |
+ ! | INPUT/ (via common block) |
+ ! | ^^^^^^ uairDY(mx,my,mz): Advection Vector: x-----Direction |
+ ! | vairDY(mx,my,mz): Advection Vector: y-----Direction |
+ ! | wsigDY(mx,my,mz): Advection Vector: sigma-Direction |
+ ! | |
+ ! | OUTPUT advffx(mx,my,mz): Advection Contribution |
+ ! | ^^^^^^ |
+ ! | |
+ ! | METHOD: 2th order accurate Time Scheme (leapfrog backw.) .and.|
+ ! | ^^^^^^ (2th order accurate Horizontal Scheme on Arakawa A grid .OR. |
+ ! | 4th order accurate Horizontal Scheme on Arakawa A grid )|
+ ! | 2th order Vertical Scheme |
+ ! | |
+ ! | REFER.: Use of A grid: Purser & Leslie, 1988, MWR 116, p.2069 |
+ ! | ^^^^^^ Time Scheme: Haltiner & Williams, 1980, 5-2, p.152 |
+ ! | Spatial Scheme: Haltiner & Williams, 1980, 5-6-5, p.135 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ integer nordAV
+
+ real ffx(mx, my, mz) ! uairdy
+ real advffx(mx, my, mz)
+
+ real ffy(mx, my, mz) ! vairdy
+ real advffy(mx, my, mz)
+
+ ! +--Contribution to Advection
+ ! + =========================
+ !$OMP PARALLEL do private (i,j,k)
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz8(i, j, k) = ffx(i, j, k)
+ WPxyz8(i, j, k) = ffy(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ ! +--2th centered Differences / x-----Direction
+ ! + ------------------------------------------
+
+ if(nordAV == 2) then
+
+ ! do k=1,mz
+ do i = 1, mx
+ do j = 1, my
+ WTxyz1(i, j, k) = uairDY(i, j, k) * dxinv3(i, j) * ( &
+ WTxyz8(im1(i), j, k) - WTxyz8(ip1(i), j, k))
+ WPxyz1(i, j, k) = uairDY(i, j, k) * dxinv3(i, j) * ( &
+ WPxyz8(im1(i), j, k) - WPxyz8(ip1(i), j, k))
+ enddo
+ enddo
+ !c #vL end do
+
+ ! +--2th centered Differences / y-----Direction
+ ! + ------------------------------------------
+
+ !c #vL do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz2(i, j, k) = vairDY(i, j, k) * dyinv3(i, j) * ( &
+ WTxyz8(i, jm1(j), k) - WTxyz8(i, jp1(j), k))
+ WPxyz2(i, j, k) = vairDY(i, j, k) * dyinv3(i, j) * ( &
+ WPxyz8(i, jm1(j), k) - WPxyz8(i, jp1(j), k))
+ enddo
+ enddo
+ ! end do
+
+ else
+ ! +--4th centered Differences / x-----Direction
+ ! + ------------------------------------------
+
+ ! do k=1,mz
+ do i = 1, mx
+ do j = 1, my
+ WTxyz1(i, j, k) = uairDY(i, j, k) * dxinv3(i, j) * fac43 * ( &
+ 0.125 * (WTxyz8(ip2(i), j, k) - WTxyz8(im2(i), j, k)) &
+ - WTxyz8(ip1(i), j, k) + WTxyz8(im1(i), j, k))
+ WPxyz1(i, j, k) = uairDY(i, j, k) * dxinv3(i, j) * fac43 * ( &
+ 0.125 * (WPxyz8(ip2(i), j, k) - WPxyz8(im2(i), j, k)) &
+ - WPxyz8(ip1(i), j, k) + WPxyz8(im1(i), j, k))
+ enddo
+ enddo
+ !c #vL end do
+
+ ! +--4th centered Differences / y-----Direction
+ ! + ------------------------------------------
+ !c #vL do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz2(i, j, k) = vairDY(i, j, k) * dyinv3(i, j) * fac43 * ( &
+ 0.125 * (WTxyz8(i, jp2(j), k) - WTxyz8(i, jm2(j), k)) &
+ - WTxyz8(i, jp1(j), k) + WTxyz8(i, jm1(j), k))
+ WPxyz2(i, j, k) = vairDY(i, j, k) * dyinv3(i, j) * fac43 * ( &
+ 0.125 * (WPxyz8(i, jp2(j), k) - WPxyz8(i, jm2(j), k)) &
+ - WPxyz8(i, jp1(j), k) + WPxyz8(i, jm1(j), k))
+ enddo
+ enddo
+ ! end do
+ endif
+
+ ! +--2th centered Differences / sigma-Direction / Energy conserving
+ ! + --- (Haltiner and Williams, 1980, 7.2.2, Eqn. (7-47b) p.220) ---
+ ! + --------------------------------------------------------
+
+ ! do k= 1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz6(i, j, k) = ffx(i, j, k) - ffx(i, j, kp1(k))
+ WPxyz6(i, j, k) = ffy(i, j, k) - ffy(i, j, kp1(k))
+ if(k >= 2) then
+ WTxyz6(i, j, km1(k)) = ffx(i, j, km1(k)) - ffx(i, j, k)
+ WPxyz6(i, j, km1(k)) = ffy(i, j, km1(k)) - ffy(i, j, k)
+ endif
+ enddo
+ enddo
+ ! end do
+
+ if(k == 1) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz3(i, j, k) = WTxyz6(i, j, k) * wsigDY(i, j, k) &
+ * 0.5 / dsigm1(1)
+ WPxyz3(i, j, k) = WPxyz6(i, j, k) * wsigDY(i, j, k) &
+ * 0.5 / dsigm1(1)
+ enddo
+ enddo
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz3(i, j, k) = (WTxyz6(i, j, k) * wsigDY(i, j, k) &
+ + WTxyz6(i, j, km1(k)) * wsigDY(i, j, km1(k))) &
+ * 0.5 / dsigm1(k)
+ WPxyz3(i, j, k) = (WPxyz6(i, j, k) * wsigDY(i, j, k) &
+ + WPxyz6(i, j, km1(k)) * wsigDY(i, j, km1(k))) &
+ * 0.5 / dsigm1(k)
+ enddo
+ enddo
+ endif
+
+ ! +--Sum of the Contributions
+ ! + ========================
+
+ do i = ip11, mx1
+ do j = jp11, my1
+ ! do k= 1,mz
+ advffx(i, j, k) = WTxyz1(i, j, k) + WTxyz2(i, j, k) + WTxyz3(i, j, k)
+ advffy(i, j, k) = WPxyz1(i, j, k) + WPxyz2(i, j, k) + WPxyz3(i, j, k)
+ ! end do
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+end
diff --git a/MAR/code_mar/dynadv_hor.f90 b/MAR/code_mar/dynadv_hor.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8f091c357b50379eae4007cc3819794ca043d63f
--- /dev/null
+++ b/MAR/code_mar/dynadv_hor.f90
@@ -0,0 +1,788 @@
+#include "MAR_pp.def"
+subroutine DYNadv_hor(qqmass, ff, fp0, fp1, fu, fv)
+ ! +
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW 27-09-2001 MAR |
+ ! | subroutine DYNadv_hor includes the Horizontal Advection Contribution |
+ ! | solved by using a Cubic Spline Technique |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: fp0: mass |
+ ! | ^^^^^ fu: advection velocity, x-direction, (e.g., uairDY) |
+ ! | fv: advection velocity, y-direction, (e.g., vairDY) |
+ ! | |
+ ! | iterun: Iteration Index |
+ ! | openLB: Zero-Gradient LBC Switch |
+ ! | FirstC: First Call at time=t Switch |
+ ! | qqmass: Mass Conservation Switch |
+ ! | |
+ ! | INPUT &/ ff: advected variable, which may be: |
+ ! | OUTPUT : uairDY,vairDY, pktaDY, qvDY, qwHY,qrHY, qiHY,ccniHY,qsHY |
+ ! | ^^^^^^^^ uairDY : x-wind speed component (m/s) |
+ ! | vairDY : y-wind speed component (m/s) |
+ ! | pktaDY: Potential Temperature divided by 100.[kPa]**(R/Cp) |
+ ! | qvDY: Air specific Humidity (kg/kg) |
+ ! | ****HY: Hydrometeor Concentration (kg/kg) |
+ ! | |
+ ! | METHOD : The following Contributions may be taken into account: |
+ ! | ^^^^^^^^ du/dt:=-udu/dx -vdu/dy |
+ ! | dv/dt:=-udv/dx -vdv/dy |
+ ! | dP/dt:=-udP/dx -vdP/dy (Potential Temperature) |
+ ! | dq/dt:=-udq/dx -vdq/dy (Water Species) |
+ ! | Correction for Mass Conservation (qqmass = .true.) |
+ ! | is based on the assumption that the meteorological fields |
+ ! | at Lateral Boundaries (LB) change only through relaxation |
+ ! | of MAR Fields towards Large Scale Meteorological Fields, |
+ ! | ==> Total Mass remains constant during "inner" Advection |
+ ! | (i1,i2) = (1,mx) ==> correction operated at LB's |
+ ! | ( correction slightly inconsistent ) |
+ ! | (i1,i2) = (2,mx-1) ==> no correction operated at LB's |
+ ! | (LB relaxation slightly badly conditioned) |
+ ! | Inclusion of Mass Flux at the LB's causes a conflict |
+ ! | with LBC scheme |
+ ! | This is verified by the onset of spurious waves at LB's |
+ ! | |
+ ! | REFER. : Alpert, thesis, 1980 |
+ ! | ^^^^^^^^ Pielke, Mesoscale Meteorological Modeling, 297--307, 1984 |
+ ! | (Seibert and Morariu, JAM, p.118, 1991) |
+ ! | |
+ ! | # OPTIONS: #MC (Mass Correction) performed |
+ ! | # ^^^^^^^^ #MD (Mass Difference) Correction preferred |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_hy
+ use mar_CU
+ use mar_lb
+ use mar_wk
+ ! +
+ implicit none
+
+ ! qqmass : mass conservation switch
+ logical, intent(in) :: qqmass
+
+ integer i, j, k, m
+ real fp0(mx, my)
+ real fp1(mx, my)
+ real ff(mx, my, mz)
+ real fu(mx, my, mz)
+ real fv(mx, my, mz)
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer iunPos, junPos, iindex, jindex
+ ! +
+ integer i1_adh, i2_adh, j1_adh, j2_adh, k_pdim
+ parameter(i1_adh=1, i2_adh=mx, j1_adh=1, j2_adh=my)
+ parameter(k_pdim=mz)
+#if(QB)
+ common / DYNadv_hor_loc / i1_adh, i2_adh, j1_adh, j2_adh
+#endif
+#if(MC)
+ real sumMav
+#endif
+ real sumMx
+ common / DYNadv_horrloc / sumMx(mz)
+ ! +
+ real dff
+ real f0(mx, my, mz)
+ real sumM0(mz), sumM1(mz)
+ real sumP0(mz), sumP1(mz)
+ real sumF0(mz)
+ real rsum, rsumd, rsumds, rsumda, FlwPos
+ ! +
+#if(SP)
+ logical log_xx, log_yy
+#endif
+ ! +
+ logical qqflux
+ logical NestOK
+ ! +
+ ! +
+ ! +--DATA
+ ! + ====
+ ! +
+ data qqflux/.false./
+ data NestOK/.true./
+ ! +
+ ! +
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +
+ ! +
+ ! +--Conservation: Mass
+ ! + ==================
+ ! +
+ if(qqmass) then
+ if(FirstC) then
+#if(MC)
+ ! +
+ ! +--Interior of the Model Domain
+ ! + ----------------------------
+ ! +
+ if(qqflux) then
+ do k = 1, k_pdim
+ sumM0(k) = 0.0
+ sumM1(k) = 0.0
+ do j = j1_adh, j2_adh
+ do i = i1_adh, i2_adh
+ sumM0(k) = sumM0(k) + fp0(i, j)
+ sumM1(k) = sumM1(k) + fp1(i, j)
+ enddo
+ enddo
+ enddo
+ else
+ do k = 1, k_pdim
+ sumM0(k) = 0.0
+ sumM1(k) = 0.0
+ do j = 1, my
+ do i = 1, mx
+ sumM0(k) = sumM0(k) + fp0(i, j)
+ sumM1(k) = sumM1(k) + fp1(i, j)
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Mass Inflow / x-Lateral Boundaries
+ ! + ----------------------------------
+ ! +
+ if(mmx > 1 .and. qqflux) then
+ ! +
+ ! +--"x-small" Boundary
+ ! + ~~~~~~~~~~~~~~~~~~
+ i = i1_adh
+ do k = 1, k_pdim
+ do j = j1_adh, j2_adh
+ sumM0(k) = sumM0(k) + fp0(i, j) * fu(i, j, k) * dtx
+ enddo
+ ! +
+ ! +--"x-large" Boundary
+ ! + ~~~~~~~~~~~~~~~~~~
+ i = i2_adh
+ do j = j1_adh, j2_adh
+ sumM0(k) = sumM0(k) - fp0(i, j) * fu(i, j, k) * dtx
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Mass Inflow / y-Lateral Boundaries
+ ! + ----------------------------------
+ ! +
+ if(mmy > 1 .and. qqflux) then
+ ! +
+ ! +--"y-small" Boundary
+ ! + ~~~~~~~~~~~~~~~~~~
+ j = j1_adh
+ do k = 1, k_pdim
+ do i = i1_adh, i2_adh
+ sumM0(k) = sumM0(k) + fp0(i, j) * fv(i, j, k) * dtx
+ enddo
+ ! +
+ ! +--"y-large" Boundary
+ ! + ~~~~~~~~~~~~~~~~~~
+ j = j2_adh
+ do i = i1_adh, i2_adh
+ sumM0(k) = sumM0(k) - fp0(i, j) * fv(i, j, k) * dtx
+ enddo
+ enddo
+ endif
+ sumMav = 0.
+#endif
+ do k = 1, k_pdim
+ sumMx(k) = 1.
+#if(MC)
+ sumMx(k) = sumM0(k) / sumM1(k)
+ sumMav = sumMav + sumMx(k) * dsigm1(k)
+#endif
+ enddo
+#if(MC)
+ do j = j1_adh, j2_adh
+ do i = i1_adh, i2_adh
+ fp1(i, j) = fp1(i, j) * sumMav
+ enddo
+ enddo
+#endif
+ endif
+ ! +
+ ! +
+ ! +--Conservation: Property
+ ! + ======================
+ ! +
+ ! +--Interior of the Model Domain
+ ! + ----------------------------
+ ! +
+ if(qqflux) then
+ do k = 1, k_pdim
+ sumP0(k) = 0.0
+ sumF0(k) = 0.0
+ do j = j1_adh, j2_adh
+ do i = i1_adh, i2_adh
+ f0(i, j, k) = ff(i, j, k) * fp0(i, j)
+ sumP0(k) = sumP0(k) + f0(i, j, k)
+ enddo
+ enddo
+ enddo
+ else
+ do k = 1, k_pdim
+ sumP0(k) = 0.0
+ do j = 1, my
+ do i = 1, mx
+ f0(i, j, k) = ff(i, j, k) * fp0(i, j)
+ sumP0(k) = sumP0(k) + f0(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Mass Inflow / x-Lateral Boundaries
+ ! + ----------------------------------
+ ! +
+ if(mmx > 1 .and. qqflux) then
+ do k = 1, k_pdim
+ i = i1_adh
+ do j = j1_adh, j2_adh
+ sumF0(k) = sumF0(k) &
+ + ff(i, j, k) * fp0(i, j) * fu(i, j, k) * dtx
+ enddo
+ i = i2_adh
+ do j = j1_adh, j2_adh
+ sumF0(k) = sumF0(k) &
+ - ff(i, j, k) * fp0(i, j) * fu(i, j, k) * dtx
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Mass Inflow / y-Lateral Boundaries
+ ! + ----------------------------------
+ ! +
+ if(mmy > 1 .and. qqflux) then
+ do k = 1, k_pdim
+ j = j1_adh
+ do i = i1_adh, i2_adh
+ sumF0(k) = sumF0(k) &
+ + ff(i, j, k) * fp0(i, j) * fv(i, j, k) * dtx
+ enddo
+ j = j2_adh
+ do i = i1_adh, i2_adh
+ sumF0(k) = sumF0(k) &
+ - ff(i, j, k) * fp0(i, j) * fv(i, j, k) * dtx
+ enddo
+ enddo
+ endif
+ if(qqflux) then
+ do k = 1, k_pdim
+ sumP0(k) = sumP0(k) + sumF0(k)
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Positive Definiteness Condition
+ ! + -------------------------------
+ ! +
+ do k = 1, k_pdim
+ sumP0(k) = max(sumP0(k), zero)
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Time Splitting (Alternate Direction)
+ ! + ====================================
+ ! +
+#if(SP)
+ log_xx = .false.
+ log_yy = .false.
+#endif
+ ! +
+300 continue
+#if(SP)
+ if(mod(itexpe, 2) == 0 .and. .not. log_yy) go to 301
+#endif
+ ! +
+ ! +
+ ! +--Advection Contribution following x
+ ! + ==================================
+ ! +
+ if(mmx > 1) then
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz1(i, j, k) = fu(i, j, k) * dtx
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Derivative, LBC
+ ! + ---------------------------
+ ! +
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz2(1, j, k) = 0.0
+ WKxyz2(mx, j, k) = 0.0
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Derivative, Forward Sweep
+ ! + --------------------------------------
+ ! +
+ do i = ip11, mx1
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz2(i, j, k) = (3.0 * (ff(i + 1, j, k) - ff(i - 1, j, k)) / dx &
+ - WKxyz2(i - 1, j, k)) / CUspxh(i)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Derivative, Backward Sweep
+ ! + --------------------------------------
+ ! +
+ do i = mx2, ip11, -1
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz2(i, j, k) = CUspxb(i) * WKxyz2(i + 1, j, k) + WKxyz2(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Difference
+ ! + ----------------------
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz2(i, j, k) = WKxyz2(i, j, k) * dx
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Interpolated Variable
+ ! + ---------------------
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz3(i, j, k) = WKxyz1(i, j, k) * WKxyz1(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Direction of Advection
+ ! + ----------------------
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz4(i, j, k) = sign(unun, WKxyz1(i, j, k))
+ iunPos = WKxyz4(i, j, k)
+ iindex = max(1, i - iunPos)
+ iindex = min(mx, iindex)
+ WKxyz5(i, j, k) = WKxyz2(iindex, j, k)
+ WKxyz6(i, j, k) = WKxyz4(i, j, k) * (ff(iindex, j, k) - ff(i, j, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Advection
+ ! + ---------
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz7(i, j, k) = WKxyz6(i, j, k) + WKxyz6(i, j, k) + WKxyz2(i, j, k)
+ WKxyz8(i, j, k) = WKxyz7(i, j, k) + WKxyz6(i, j, k) + WKxyz2(i, j, k)
+ WKxyz6(i, j, k) = ff(i, j, k) - WKxyz1(i, j, k) * WKxyz2(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ WKxyz6(i, j, k) = ff(i, j, k) - WKxyz1(i, j, k) * WKxyz2(i, j, k) &
+ + WKxyz4(i, j, k) * WKxyz3(i, j, k) * (WKxyz8(i, j, k) + WKxyz5(i, j, k)) &
+ - WKxyz1(i, j, k) * WKxyz3(i, j, k) * (WKxyz7(i, j, k) + WKxyz5(i, j, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Inflow LBC
+ ! + ----------
+ ! +
+ if(qqflux) then
+ ! +
+ ! +--Large Scale Contribution over dt (dff, to be implemented)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(NestOK) then
+ dff = 0.
+ ! +
+ ! +--Host Model Solution is preferred ("outer" solution if inflow included)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do k = 1, k_pdim
+ do j = 1, my
+ WKxyz6(1, j, k) = ff(1, j, k) + dff
+ WKxyz6(mx, j, k) = ff(mx, j, k) + dff
+ enddo
+ enddo
+ ! +
+ ! +--MAR Solution is preferred ("inner" solution if inflow included)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ else
+ do k = 1, k_pdim
+ do j = 1, my
+ FlwPos = max(zero, sign(unun, WKxyz4(1, j, k)))
+ WKxyz6(1, j, k) = WKxyz6(1, j, k) * (unun - FlwPos) &
+ + ff(1, j, k) * FlwPos
+ FlwPos = max(zero, sign(unun, WKxyz4(mx, j, k)))
+ WKxyz6(mx, j, k) = WKxyz6(mx, j, k) * FlwPos &
+ + ff(mx, j, k) * (unun - FlwPos)
+ enddo
+ enddo
+ endif
+ ! +
+ ! +--Host Model Solution is preferred
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ else
+ do k = 1, k_pdim
+ do j = 1, my
+ WKxyz6(1, j, k) = ff(1, j, k)
+ WKxyz6(mx, j, k) = ff(mx, j, k)
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Finalisation
+ ! + ------------
+ ! +
+ do i = 1, mx
+ do k = 1, k_pdim
+ do j = jp11, my1
+ ff(i, j, k) = WKxyz6(i, j, k)
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+#if(SP)
+ log_xx = .true.
+#endif
+ ! +
+ ! +
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +
+ ! +
+ ! +--Time Splitting (Alternate Direction)
+ ! + ====================================
+ ! +
+301 continue
+#if(SP)
+ if(log_yy) go to 302
+#endif
+ ! +
+ ! +
+ ! +--Advection Contribution following y
+ ! + ==================================
+ ! +
+ if(mmy > 1) then
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = fv(i, j, k) * dtx
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Derivative, LBC
+ ! + ---------------------------
+ ! +
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz2(1, 1, k) = 0.0
+ WKxyz2(1, my, k) = 0.0
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Derivative, Forward Sweep
+ ! + --------------------------------------
+ ! +
+ do j = jp11, my1
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = (3.0 * (ff(i, j + 1, k) - ff(i, j - 1, k)) / dx &
+ - WKxyz2(i, j - 1, k)) / CUspyh(j)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Derivative, Backward Sweep
+ ! + --------------------------------------
+ ! +
+ do j = my2, jp11, -1
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = CUspyb(j) * WKxyz2(i, j + 1, k) + WKxyz2(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--First Order Difference
+ ! + ----------------------
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = WKxyz2(i, j, k) * dx
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Interpolated Variable
+ ! + ---------------------
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz3(i, j, k) = WKxyz1(i, j, k) * WKxyz1(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Direction of Advection
+ ! + ----------------------
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = sign(unun, WKxyz1(i, j, k))
+ junPos = WKxyz4(i, j, k)
+ jindex = max(1, j - junPos)
+ jindex = min(my, jindex)
+ WKxyz5(i, j, k) = WKxyz2(i, jindex, k)
+ WKxyz6(i, j, k) = WKxyz4(i, j, k) * (ff(i, jindex, k) - ff(i, j, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Advection
+ ! + ---------
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = WKxyz6(i, j, k) + WKxyz6(i, j, k) + WKxyz2(i, j, k)
+ WKxyz8(i, j, k) = WKxyz7(i, j, k) + WKxyz6(i, j, k) + WKxyz2(i, j, k)
+ WKxyz6(i, j, k) = ff(i, j, k) - WKxyz1(i, j, k) * WKxyz2(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ ff(i, j, k) = ff(i, j, k) - WKxyz1(i, j, k) * WKxyz2(i, j, k) &
+ + WKxyz4(i, j, k) * WKxyz3(i, j, k) * (WKxyz8(i, j, k) + WKxyz5(i, j, k)) &
+ - WKxyz1(i, j, k) * WKxyz3(i, j, k) * (WKxyz7(i, j, k) + WKxyz5(i, j, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Inflow LBC
+ ! + ----------
+ ! +
+ if(qqflux) then
+ ! +
+ ! +--Large Scale Contribution over dt (dff, to be implemented)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(NestOK) then
+ dff = 0.
+ ! +
+ ! +--Host Model Solution is preferred ("outer" solution if inflow included)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do k = 1, k_pdim
+ do i = 1, mx
+ WKxyz6(i, 1, k) = ff(i, 1, k)
+ WKxyz6(i, my, k) = ff(i, my, k)
+ enddo
+ enddo
+ ! +
+ ! +--Nested Model Solution is preferred
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! +
+ ! +--MAR Solution is preferred ("inner" solution if inflow included)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ else
+ do k = 1, k_pdim
+ do i = 1, mx
+ FlwPos = max(zero, sign(unun, WKxyz4(i, 1, k)))
+ WKxyz6(i, 1, k) = WKxyz6(i, 1, k) * (unun - FlwPos) &
+ + ff(i, 1, k) * FlwPos
+ FlwPos = max(zero, sign(unun, WKxyz4(i, my, k)))
+ WKxyz6(i, my, k) = WKxyz6(i, my, k) * FlwPos &
+ + ff(i, my, k) * (unun - FlwPos)
+ enddo
+ enddo
+ endif
+ ! +
+ ! +--Host Model Solution is preferred
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ else
+ do k = 1, k_pdim
+ do i = 1, mx
+ WKxyz6(i, 1, k) = ff(i, 1, k)
+ WKxyz6(i, my, k) = ff(i, my, k)
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! +--Finalisation
+ ! + ------------
+ ! +
+ do j = 1, my
+ do k = 1, k_pdim
+ do i = ip11, mx1
+ ff(i, j, k) = WKxyz6(i, j, k)
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+#if(SP)
+ log_yy = .true.
+ if(.not. log_xx) go to 300
+#endif
+302 continue
+ ! +
+ ! +
+ ! +--Conservation
+ ! + ============
+ ! +
+ if(qqmass) then
+ ! +
+ ! +
+ ! +--Fluxes at the Lateral Boundaries through Advection
+ ! + -------------------------------------------------------
+ ! +
+ if(qqflux) then
+ do k = 1, k_pdim
+ sumP1(k) = 0.0
+ do j = j1_adh, j2_adh
+ do i = i1_adh, i2_adh
+ WKxy1(i, j) = ff(i, j, k) * fp1(i, j)
+ sumP1(k) = sumP1(k) + WKxy1(i, j)
+ enddo
+ enddo
+ ! +
+ rsumd = sumP1(k)
+#if(MD)
+ rsumd = sumP1(k) - sumP0(k)
+#endif
+ rsumds = sign(unun, rsumd)
+ rsumda = abs(rsumd)
+ rsumd = max(eps9, rsumda) * rsumds
+ rsum = sumP0(k) / rsumd
+#if(MD)
+ rsum = sumF0(k) / rsumd
+#endif
+ do j = j1_adh, j2_adh
+ do i = i1_adh, i2_adh
+ ff(i, j, k) = ff(i, j, k) * rsum
+#if(MD)
+ ff(i, j, k) = (f0(i, j, k) &
+ + (WKxy1(i, j) - f0(i, j, k)) * rsum) &
+ / fp1(i, j)
+#endif
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Fluxes at the Lateral Boundaries only through the nudging Procedure
+ ! + -------------------------------------------------------------------
+ ! +
+ else
+ ! +
+ do k = 1, k_pdim
+ sumP1(k) = 0.0
+ do j = 1, my
+ do i = 1, mx
+ sumP1(k) = sumP1(k) + ff(i, j, k) * fp1(i, j)
+ enddo
+ enddo
+ ! +
+ rsumd = sumP1(k) * sumMx(k)
+ rsumds = sign(unun, rsumd)
+ rsumda = abs(rsumd)
+ rsumd = max(eps9, rsumda) * rsumds
+ rsum = sumP0(k) / rsumd
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = ff(i, j, k) * rsum
+ enddo
+ enddo
+ ! +
+ enddo
+ endif
+ ! +
+ endif
+ ! +
+ ! +
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +
+ ! +
+ return
+end
diff --git a/MAR/code_mar/dynadv_lfb.f90 b/MAR/code_mar/dynadv_lfb.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dbeb0ffd7e2826b85345df89923447d19c18ad38
--- /dev/null
+++ b/MAR/code_mar/dynadv_lfb.f90
@@ -0,0 +1,601 @@
+#include "MAR_pp.def"
+subroutine DYNadv_LFB(norder)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW 08-12-2022 MAR |
+ ! | subroutine DYNadv_LFB manages Leap-Frog Backward Advection Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT/ (via common block) |
+ ! | ^^^^^^ iterun : Long Time Step Counter |
+ ! | ntFast : Time Step Counter Maximum Value |
+ ! | micphy : Hydrometeors Switch |
+ ! | |
+ ! | INPUT/ (via common block) |
+ ! | OUTPUT pktaDY(mx,my,mzz) Potent. Temperat. / p_0**kappa |
+ ! | ^^^^^^ qvDY(mx,my,mz): Water Vapor Concentration [kg/kg] |
+ ! | ccniHY(mx,my,mz): Ice crystals Number [-] |
+ ! | qiHY(mx,my,mz): Ice crystals Concentration [kg/kg] |
+ ! | qsHY(mx,my,mz): Snow Flakes Concentration [kg/kg] |
+ ! | qwHY(mx,my,mz): Cloud Dropl. Concentration [kg/kg] |
+ ! | qrHY(mx,my,mz): Rain Drops Concentration [kg/kg] |
+ ! | SEE DYNdgz: uairDY(mx,my,mz): Wind Speed x-Direction [m/s] |
+ ! | vairDY(mx,my,mz): Wind Speed y-Direction [m/s] |
+ ! | |
+ ! | METHOD: 2th order accurate Time Scheme (leapfrog backw.) .and.|
+ ! | ^^^^^^ (2th order accurate Horizontal Scheme on Arakawa A grid .OR. |
+ ! | 4th order accurate Horizontal Scheme on Arakawa A grid )|
+ ! | 2th order Vertical Scheme |
+ ! | |
+ ! | CAUTION: This routine must be used |
+ ! | ^^^^^^^ with a positive definite restoring Procedure |
+ ! | for positive definite Variables |
+ ! | (Such a Procedure is setup after digital filtering in MAR) |
+ ! | |
+ ! | REFER.: Use of A grid: Purser & Leslie, 1988, MWR 116, p.2069 |
+ ! | ^^^^^^ Time Scheme: Haltiner & Williams, 1980, 5-2, p.152 |
+ ! | Spatial Scheme: Haltiner & Williams, 1980, 5-6-5, p.135 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_sl
+ use mar_hy
+#if(TC)
+ use mar_tc
+#endif
+#if(iso)
+ use mariso, only: wiso, niso, Rdefault, &
+ qvDY_iso, qvapSL_iso, qiHY_iso, &
+ qsHY_iso, qwHY_iso, qrHY_iso, qsrfHY_iso
+#endif
+
+ implicit none
+
+ integer, intent(in) :: norder
+ ! +--Local Variables
+ ! + ================
+ ! iswater : to activate track_water
+ logical :: iswater
+ ! qqmass : mass conservation switch
+ logical :: qqmass
+ integer i, j, k, m
+ ! ntSlow = Time Step Counter Maximum Value
+ integer ntSlow
+ integer n
+ ! ff : Advected Variable
+ real ff(mx, my, mzz)
+#if(iso)
+ ! ff_Riso : isotopic ratio of Advected Variable
+ real ff_Riso(niso, mx, my, mzz)
+#endif
+
+ ! +--DATA
+ ! + ====
+ ntSlow = ntFast
+
+ ! +--Advection of x-Momentum (uairDY)
+ ! + ================================
+ qqmass = .false.
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! ff(i,j,k) = uairDY(i,j,k)
+ ! end do
+ ! end do
+ ! end do
+ ! k= mzz
+ ! do j=1,my
+ ! do i=1,mx
+ ! ff(i,j,k) = 0.
+ ! end do
+ ! end do
+ !c #NV if (no_vec) then
+ !C + *************
+ !c #NV call DYNadv_LFB_2s(ntSlow,norder,ff)
+ !C + *************
+ !c #NV else
+ !C + *************
+ ! call DYNadv_LFB_2v(ntSlow,norder,ff)
+ !C + *************
+ !c #NV end if
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! uairDY(i,j,k) = ff(i,j,k)
+ ! end do
+ ! end do
+ ! end do
+
+ !C +--Advection of y-Momentum (vairDY)
+ !C + ================================
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! ff(i,j,k) = vairDY(i,j,k)
+ ! end do
+ ! end do
+ ! end do
+ ! k= mzz
+ ! do j=1,my
+ ! do i=1,mx
+ ! ff(i,j,k) = 0.
+ ! end do
+ ! end do
+
+ !c #NV if (no_vec) then
+ !C + *************
+ !c #NV call DYNadv_LFB_2s(ntSlow,norder,ff)
+ !C + *************
+ !c #NV else
+ !C + *************
+ ! call DYNadv_LFB_2v(ntSlow,norder,ff)
+ !C + *************
+ !c #NV end if
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! vairDY(i,j,k) = ff(i,j,k)
+ ! end do
+ ! end do
+ ! end do
+
+ ! +--Advection of Heat (pktaDY)
+ ! + ==========================
+ qqmass = .false.
+ ! cCA norder is an input of the routine, already equal to 4
+ ! cCA cannot be assigned here because of intent(in)
+ ! cCA todo : check with XF if norder should be let as an option or not
+ ! norder = 4
+ do k = 1, mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ !cCA ff = pkta -> not water
+ iswater = .false.
+ !cCA : At first call of DYNadv_LFB_2p, qqmass = .false. -> setup of dtSlow
+ ! + *************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + *************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Advection of Water Vapor (qvDY)
+ ! + ===============================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qvapSL(i, j)
+ enddo
+ enddo
+
+#if(iso)
+ ! Compute isotopic ratio *before* advection of water vapor
+ ! Advection of water vapor isotopes, based on LMDZ : dyn3dmem/vlsplt_loc.F/vlz_loc
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ call Riso_from_qiso(wiso, qvDY_iso(wiso, i, j, k), qvDY(i, j, k), ff_Riso(wiso, i, j, k))
+ enddo
+ enddo
+ enddo
+ enddo
+ ! k = mzz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ call Riso_from_qiso(wiso, qvapSL_iso(wiso, i, j), qvapSL(i, j), ff_Riso(wiso, i, j, mzz))
+ enddo
+ enddo
+ enddo
+#endif
+
+ !cCA Mass conservation of water vapor on the full domain (xyz)
+ qqmass = .true.
+ !cCA ff = qvDY -> track water
+ iswater = .true.
+ ! + *************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + *************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qvDY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+
+#if(iso)
+ ! qqmass = .false. because mass conservation is on qvDY
+ qqmass = .false.
+ do wiso = 1, niso
+ ! + *************
+ call DYNadv_LFB_2p(qqmass, ntSlow, norder, ff_Riso(wiso, :, :, :))
+ ! + *************
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qvDY_iso(wiso, i, j, k) = ff_Riso(wiso, i, j, k) * qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+
+ if(micphy) then
+ ! +--Advection of Ice Crystals Nb (ccniHY)
+ ! + =====================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = ccniHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = 0.
+ enddo
+ enddo
+
+ !cCA ff = ccniHY -> do not track water
+ iswater = .false.
+ ! + ****************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + ****************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ccniHY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Advection of Cloud Crystals (qiHY)
+ ! + ==================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qiHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = 0.
+ enddo
+ enddo
+
+#if(iso)
+ ! Compute isotopic ratio *before* advection of cloud ice
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ call Riso_from_qiso(wiso, qiHY_iso(wiso, i, j, k), qiHY(i, j, k), ff_Riso(wiso, i, j, k))
+ enddo
+ enddo
+ enddo
+ enddo
+ ! k = mzz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ ff_Riso(wiso, i, j, mzz) = Rdefault(wiso)
+ enddo
+ enddo
+ enddo
+#endif
+ !cCA Mass conservation on the full domain (xyz)
+ qqmass = .true.
+ !cCA ff = qiHY -> do not track water
+ iswater = .false.
+ ! + ****************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + ****************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qiHY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ ! qqmass = .false. because mass conservation is on qiHY
+ qqmass = .false.
+ do wiso = 1, niso
+ ! + *************
+ call DYNadv_LFB_2p(qqmass, ntSlow, norder, ff_Riso(wiso, :, :, :))
+ ! + *************
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qiHY_iso(wiso, i, j, k) = ff_Riso(wiso, i, j, k) * qiHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+ ! +--Advection of Snow Flakes (qsHY)
+ ! + ===============================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qsHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qsrfHY(i, j)
+ enddo
+ enddo
+
+#if(iso)
+ ! Compute isotopic ratio *before* advection of snow flakes
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ call Riso_from_qiso(wiso, qsHY_iso(wiso, i, j, k), qsHY(i, j, k), ff_Riso(wiso, i, j, k))
+ enddo
+ enddo
+ enddo
+ enddo
+ ! k = mzz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ ! todo : track qsrfHY -> qsrfHY_iso
+ call Riso_from_qiso(wiso, qsrfHY_iso(wiso, i, j), qsrfHY(i, j), ff_Riso(wiso, i, j, mzz))
+ enddo
+ enddo
+ enddo
+#endif
+ !cCA Mass conservation of water vapor on the full domain (xyz)
+ qqmass = .true.
+ !cCA ff = qsHY -> do not track water
+ iswater = .false.
+ ! + ****************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + ****************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qsHY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ ! qqmass = .false. because mass conservation is on qsHY
+ qqmass = .false.
+ do wiso = 1, niso
+ ! + *************
+ call DYNadv_LFB_2p(qqmass, ntSlow, norder, ff_Riso(wiso, :, :, :))
+ ! + *************
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qsHY_iso(wiso, i, j, k) = ff_Riso(wiso, i, j, k) * qsHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+ ! +--Advection of Cloud Dropplets (qwHY)
+ ! + ===================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qwHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = 0.
+ enddo
+ enddo
+#if(iso)
+ ! Compute isotopic ratio *before* advection of cloud ice
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ call Riso_from_qiso(wiso, qwHY_iso(wiso, i, j, k), qwHY(i, j, k), ff_Riso(wiso, i, j, k))
+ enddo
+ enddo
+ enddo
+ enddo
+ ! k = mzz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ ff_Riso(wiso, i, j, mzz) = Rdefault(wiso)
+ enddo
+ enddo
+ enddo
+#endif
+ !cCA Mass conservation on the full domain (xyz)
+ qqmass = .true.
+ !cCA ff = qwHY -> do not track water
+ iswater = .false.
+ ! + *************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + *************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qwHY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ ! qqmass = .false. because mass conservation is on qwHY
+ qqmass = .false.
+ do wiso = 1, niso
+ ! + *************
+ call DYNadv_LFB_2p(qqmass, ntSlow, norder, ff_Riso(wiso, :, :, :))
+ ! + *************
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qwHY_iso(wiso, i, j, k) = ff_Riso(wiso, i, j, k) * qwHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+ ! +--Advection of Rain Drops (qrHY)
+ ! + ==============================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qrHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = 0.
+ enddo
+ enddo
+#if(iso)
+ ! Compute isotopic ratio *before* advection of cloud ice
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ call Riso_from_qiso(wiso, qrHY_iso(wiso, i, j, k), qrHY(i, j, k), ff_Riso(wiso, i, j, k))
+ enddo
+ enddo
+ enddo
+ enddo
+ ! k = mzz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ ff_Riso(wiso, i, j, mzz) = Rdefault(wiso)
+ enddo
+ enddo
+ enddo
+#endif
+ !cCA Mass conservation on the full domain (xyz)
+ qqmass = .true.
+ !cCA ff = qrHY -> do not track water
+ iswater = .false.
+ ! + ****************
+ call DYNadv_LFB_2p(iswater, qqmass, ntSlow, norder, ff)
+ ! + ****************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qrHY(i, j, k) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ ! qqmass = .false. because mass conservation is on qwHY
+ qqmass = .false.
+ do wiso = 1, niso
+ ! + *************
+ call DYNadv_LFB_2p(qqmass, ntSlow, norder, ff_Riso(wiso, :, :, :))
+ ! + *************
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qrHY_iso(wiso, i, j, k) = ff_Riso(wiso, i, j, k) * qrHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+ endif
+
+#if(TC)
+ ! +--Advection of Tracers (qxTC)
+ ! + ===========================
+ do n = 1, ntrac
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = qxTC(i, j, k, n)
+ enddo
+ enddo
+ enddo
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ ff(i, j, k) = 0.
+ enddo
+ enddo
+ if(no_vec) then
+ if(openmp) then
+ ! + ****************
+ call DYNadv_LFB_2p(qqmass, ntSlow, norder, ff)
+ ! + ****************
+ else
+ ! + *************
+ call DYNadv_LFB_2s(ntSlow, norder, ff)
+ ! + *************
+ endif
+ else
+ ! + *************
+ !cCA warning, todo : DYNadv_LFB_2v does not exist
+ call DYNadv_LFB_2v(ntSlow, norder, ff)
+ ! + *************
+ endif
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qxTC(i, j, k, n) = ff(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+
+ return
+endsubroutine DYNadv_LFB
diff --git a/MAR/code_mar/dynadv_lfb_2p.f90 b/MAR/code_mar/dynadv_lfb_2p.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4d885c6745eaae0bd32e62a8c2a1a83f684bdc65
--- /dev/null
+++ b/MAR/code_mar/dynadv_lfb_2p.f90
@@ -0,0 +1,444 @@
+#include "MAR_pp.def"
+subroutine DYNadv_LFB_2p(iswater, qqmass, niSlow, nordAV, ffx)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW 09-12-2022 MAR |
+ ! | subroutine DYNadv_LFB_2s solves Advection (LeapFrog Backward Scheme) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT/ nnSlow : Time Step Counter Maximum Value |
+ ! | ^^^^^^ |
+ ! | |
+ ! | INPUT/ (via common block) |
+ ! | ^^^^^^ qqmass : Mass Conservation Switch (+def.var.) |
+ ! | iterun : Long Time Step Counter |
+ ! | dt : Time Step |
+ ! | opstDY(mx,my) : MASS, Time Step n |
+ ! | pstDYn(mx,my) : MASS, Time Step n+1 |
+ ! | uairDY(mx,my,mz): Advection Vector: x-----Direction |
+ ! | vairDY(mx,my,mz): Advection Vector: y-----Direction |
+ ! | psigDY(mx,my,mz): Advection Vector: sigma-Direction |
+ ! | |
+ ! | INPUT/ ffx(mx,my,mz+1): Advected Variable |
+ ! | OUTPUT |
+ ! | ^^^^^^ |
+ ! | |
+ ! | METHOD: 2th order accurate Time Scheme (leapfrog backw.) .and.|
+ ! | ^^^^^^ (2th order accurate Horizontal Scheme on Arakawa A grid .OR. |
+ ! | 4th order accurate Horizontal Scheme on Arakawa A grid )|
+ ! | 2th order Vertical Scheme |
+ ! | |
+ ! | Robert Time Filter (for minimizing the computational mode) |
+ ! | |
+ ! | CAUTION: This routine must be used |
+ ! | ^^^^^^^ with a positive definite restoring Procedure |
+ ! | for positive definite Variables |
+ ! | (Such a Procedure is setup after digital filtering in MAR) |
+ ! | |
+ ! | REFER.: Use of A grid: Purser & Leslie, 1988, MWR 116, p.2069 |
+ ! | ^^^^^^ Time Scheme: Haltiner & Williams, 1980, 5-2, p.152 |
+ ! | Spatial Scheme: Haltiner & Williams, 1980, 5-6-5, p.135 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use marqqm
+ use mar_wk
+ use trackwater, only : track_water_dynadv, jtw, &
+ delta_qv, j_dynadv_hor, j_dynadv_ver, j_dynadv_sav, &
+ dqp1_h, dqp1_v, dqm1_h, dqm1_v, delta_qv_tmp
+
+ implicit none
+
+ ! iswater : check if water to activate track_water
+ logical, intent(in) :: iswater
+ ! qqmass: mass Conservation Switch
+ logical, intent(in) :: qqmass
+ ! niSlow : Time Step Counter Initial Value
+ integer, intent(in) :: niSlow
+ integer, intent(in) :: nordAV
+ ! ffx : Advected Variable (t=n)
+ real, intent(inout) :: ffx(mx, my, mzz)
+
+ integer i, j, k, m
+
+
+ ! +--Local Variables
+ ! + ================
+ ! daSlow : Initialization Switch
+ logical daSlow
+ common / DYNadv_LFB_2s_log / daSlow
+ ! dtSlow : Time Step
+ real dtSlow
+ common / DYNadv_LFB_2s_rea / dtSlow
+ real rtSlow
+ ! itSlow : Time Step Counter
+ integer itSlow
+ integer nnSlow, n0Slow
+ common / DYNadv_LFB_2s_int / nnSlow
+ ! ffm1 : Advected Variable (t=n-1)
+ real ffm1
+ ! dff : Variable Increment
+ real dff, dff_h, dff_v,flag
+
+ integer kk
+ real summ, sumn, summ_tmp
+
+ ! ffo : Advected Variable (t=n)
+ ! ffp1 : Advected Variable
+ real, allocatable :: ffp1(:, :, :)
+ real, allocatable :: ffo(:, :, :)
+
+ logical LFBord, FLhost
+ data LFBord/.false./
+ data FLhost/.true./
+
+ allocate (ffp1(mx, my, mzz))
+ allocate ( ffo(mx, my, mzz))
+
+ ! +--Start the Leapfrog Backward Scheme
+ ! + ==================================
+
+ if(.not. qqmass) then
+ if(.not. daSlow) then
+ daSlow = .true.
+ ! n0Slow : previous Nb of Time Steps
+ n0Slow = niSlow
+ else
+ ! n0Slow : previous Nb of Time Steps
+ n0Slow = nnSlow
+ endif
+ ! rtSlow : minimum acceptable Nb of Time Steps in the leap-frog Backward Scheme
+ rtSlow = CFLzDY
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ rtSlow = max(rtSlow, abs(uairDY(i, j, k)) * 2.0 * dt / dx)
+ rtSlow = max(rtSlow, abs(vairDY(i, j, k)) * 2.0 * dt / dx)
+ enddo
+ enddo
+ enddo
+ nnSlow = rtSlow + 0.5
+ nnSlow = max(nnSlow, ntFast)
+ if(mod(nnSlow, 2) == 0) nnSlow = nnSlow + 1
+ dtSlow = dt / (nnSlow + 1)
+
+ if(nnSlow /= n0Slow) then
+ write(6, 6000) nnSlow, dtSlow
+6000 format(/, 'Advection Leap-Frog Backward Properties', &
+ /, ' ntSlow = ', i6, &
+ /, ' dtSlow = ', f9.2, /, 1x)
+ endif
+ endif
+
+ ! +--Mass Conservation
+ ! + =================
+ ffo = ffx
+ ! +--Start Leap-Frog Backward
+ ! + ========================
+ sumn = 0.
+ summ = 0.
+
+ !$OMP PARALLEL DO REDUCTION(+: sumn,summ) &
+ !$OMP private (i,j,k,kk,dff,ffm1,flag,dff_v,dff_h,itSlow,summ_tmp,WTxy1,WTxy2) &
+ !$OMP schedule(dynamic)
+ do k = 1, mz
+
+ flag = 0
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(abs(ffo(i, j, k)) > 1.5 * eps9) flag = 1
+ enddo
+ enddo
+
+ if(flag == 1 ) then
+
+ ! +--Vertical Differences
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(k == 1) then
+ WTxy1(i, j) = ffo(i, j, k) - ffo(i, j, kp1(k))
+ !cCA WTxyz3 = diffz_ffo * wsig / dsigm1 = mass flux
+ WTxyz3(i, j, k) = WTxy1(i, j) * wsigDY(i, j, k) * 0.5 / dsigm1(1)
+ else
+ WTxy1(i, j) = ffo(i, j, k) - ffo(i, j, kp1(k))
+ kk = km1(k)
+ WTxy2(i, j) = ffo(i, j,kk) - ffo(i, j, k)
+ !cCA WTxyz3 = diffz_ffo * wsig / dsigm1 = mass flux
+ WTxyz3(i, j, k) = (WTxy1(i, j) * wsigDY(i, j, k ) &
+ + WTxy2(i, j) * wsigDY(i, j, kk)) * 0.5 / dsigm1(k)
+ endif
+ enddo
+ enddo
+
+
+ do itSlow = 1, nnSlow + 1
+ ! +--Mass Divergence
+ ! + ===============
+
+ ! +--2th centered Differences / sigma-Direction / Energy conserving
+ ! + --- (Haltiner and Williams, 1980, 7.2.2, Eqn. (7-47b) p.220) ---
+ ! + --------------------------------------------------------
+
+ ! +--Mass Update (Leapfrog-Backward)
+ ! + ===============================
+ ! https://en.wikipedia.org/wiki/Finite_difference_coefficient
+ !cCA -2 -1 0 1 2
+ !cCA First derivative, central difference, accuracy=4 : 1/12 −2/3 0 2/3 −1/12
+ !cCA 2/3 * (1/8 -1. 0 1. -1/8 )
+ !cCA dxinv3 = 1. / (2 dx)
+ !cCA dtSlow = dt / (1 + nnSlow) (at least 2 1/2 time steps)
+ if(itSlow == 1) then
+ if(nordAV == 2) then
+ ! do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ dff_h = uairDY(i, j, k) * dxinv3(i, j) * (ffx(im1(i), j, k) - ffx(ip1(i), j, k)) + &
+ vairDY(i, j, k) * dyinv3(i, j) * (ffx(i, jm1(j), k) - ffx(i, jp1(j), k))
+ dff_v = WTxyz3(i, j, k)
+ dff = (dff_h + dff_v) * dtSlow
+ ffx(i, j, k) = ffx(i, j, k) + dff
+ ffp1(i, j, k) = ffx(i, j, k) + dff + dff
+ if(iswater.and.track_water_dynadv) then
+ dff_h = dff_h * dtSlow
+ dff_v = dff_v * dtSlow
+ delta_qv(i, j, k, j_dynadv_hor) = delta_qv(i, j, k, j_dynadv_hor) + dff_h
+ delta_qv(i, j, k, j_dynadv_ver) = delta_qv(i, j, k, j_dynadv_ver) + dff_v
+ dqp1_h(i, j, k) = delta_qv(i, j, k, j_dynadv_hor) + dff_h + dff_h
+ dqp1_v(i, j, k) = delta_qv(i, j, k, j_dynadv_ver) + dff_v + dff_v
+ end if
+ enddo
+ enddo
+ ! end do
+ else
+ ! do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ dff_h = uairDY(i, j, k) * dxinv3(i, j) * fac43 * (&
+ 0.125 * (ffx(ip2(i), j, k) - ffx(im2(i), j, k)) &
+ - ffx(ip1(i), j, k) + ffx(im1(i), j, k)) + &
+ vairDY(i, j, k) * dyinv3(i, j) * fac43 * (&
+ 0.125 * (ffx(i, jp2(j), k) - ffx(i, jm2(j), k)) &
+ - ffx(i, jp1(j), k) + ffx(i, jm1(j), k))
+ dff_v = WTxyz3(i, j, k)
+ dff = (dff_h + dff_v) * dtSlow
+ ffx(i, j, k) = ffx(i, j, k) + dff
+ ffp1(i, j, k) = ffx(i, j, k) + dff + dff
+ if(iswater.and.track_water_dynadv) then
+ dff_h = dff_h * dtSlow
+ dff_v = dff_v * dtSlow
+ delta_qv(i, j, k, j_dynadv_hor) = delta_qv(i, j, k, j_dynadv_hor) + dff_h
+ delta_qv(i, j, k, j_dynadv_ver) = delta_qv(i, j, k, j_dynadv_ver) + dff_v
+ dqp1_h(i, j, k) = delta_qv(i, j, k, j_dynadv_hor) + dff_h + dff_h
+ dqp1_v(i, j, k) = delta_qv(i, j, k, j_dynadv_ver) + dff_v + dff_v
+ end if
+ enddo
+ enddo
+ ! end do
+ endif
+ else
+ if(itSlow <= nnSlow) then
+ if(nordAV == 2) then
+ ! do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ dff_h = uairDY(i, j, k) * dxinv3(i, j) * (ffx(im1(i), j, k) - ffx(ip1(i), j, k)) + &
+ vairDY(i, j, k) * dyinv3(i, j) * (ffx(i, jp1(j), k) - ffx(i, jp1(j), k))
+ dff_v = WTxyz3(i, j, k)
+ dff = (dff_h + dff_v) * dtSlow
+ ffm1 = ffx(i, j, k)
+ ffx(i, j, k) = ffp1(i, j, k)
+ ffp1(i, j, k) = ffm1 + dff + dff
+ if(iswater.and.track_water_dynadv) then
+ dff_h = dff_h * dtSlow
+ dff_v = dff_v * dtSlow
+ dqm1_h(i, j, k) = delta_qv(i, j, k, j_dynadv_hor)
+ dqm1_v(i, j, k) = delta_qv(i, j, k, j_dynadv_ver)
+ delta_qv(i, j, k, j_dynadv_hor) = dqp1_h(i, j, k)
+ delta_qv(i, j, k, j_dynadv_ver) = dqp1_v(i, j, k)
+ dqp1_h(i, j, k) = dqm1_h(i, j, k) + dff_h + dff_h
+ dqp1_v(i, j, k) = dqm1_v(i, j, k) + dff_v + dff_v
+ end if
+#if(rt)
+ ! +--Robert Time Filter
+ ! + ~~~~~~~~~~~~~~~~~~
+ ffx(i, j, k) = ffx(i, j, k) + &
+ Robert * (0.5 * (ffp1(i, j, k) + ffm1) - ffx(i, j, k))
+#endif
+ enddo
+ enddo
+ ! end do
+ else
+ ! do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ dff_h = uairDY(i, j, k) * dxinv3(i, j) * fac43 * (&
+ 0.125 * (ffx(ip2(i), j, k) - ffx(im2(i), j, k)) &
+ - ffx(ip1(i), j, k) + ffx(im1(i), j, k)) &
+ + vairDY(i, j, k) * dyinv3(i, j) * fac43 * ( &
+ 0.125 * (ffx(i, jp2(j), k) - ffx(i, jm2(j), k)) &
+ - ffx(i, jp1(j), k) + ffx(i, jm1(j), k))
+ dff_v = WTxyz3(i, j, k)
+ dff = (dff_h + dff_v) * dtSlow
+ ffm1 = ffx(i, j, k)
+ ffx(i, j, k) = ffp1(i, j, k)
+ ffp1(i, j, k) = ffm1 + dff + dff
+ if(iswater.and.track_water_dynadv) then
+ dff_h = dff_h * dtSlow
+ dff_v = dff_v * dtSlow
+ dqm1_h(i, j, k) = delta_qv(i, j, k, j_dynadv_hor)
+ dqm1_v(i, j, k) = delta_qv(i, j, k, j_dynadv_ver)
+ delta_qv(i, j, k, j_dynadv_hor) = dqp1_h(i, j, k)
+ delta_qv(i, j, k, j_dynadv_ver) = dqp1_v(i, j, k)
+ dqp1_h(i, j, k) = dqm1_h(i, j, k) + dff_h + dff_h
+ dqp1_v(i, j, k) = dqm1_v(i, j, k) + dff_v + dff_v
+ end if
+#if(rt)
+ ! +--Robert Time Filter
+ ! + ~~~~~~~~~~~~~~~~~~
+ ffx(i, j, k) = ffx(i, j, k) + &
+ Robert * (0.5 * (ffp1(i, j, k) + ffm1) - ffx(i, j, k))
+#endif
+ enddo
+ enddo
+ ! end do
+ endif
+ else
+ if(nordAV == 2) then
+ ! do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ dff_h = uairDY(i, j, k) * dxinv3(i, j) * &
+ (ffx(im1(i), j, k) - ffx(ip1(i), j, k)) + &
+ vairDY(i, j, k) * dyinv3(i, j) * &
+ (ffx(i, jm1(j), k) - ffx(i, jp1(j), k))
+ dff_v = WTxyz3(i, j, k)
+ dff = (dff_h + dff_v) * dtSlow
+ ffx(i, j, k) = ffx(i, j, k) + dff
+ if(iswater.and.track_water_dynadv) then
+ dff_h = dff_h * dtSlow
+ dff_v = dff_v * dtSlow
+ delta_qv(i, j, k, j_dynadv_hor) = delta_qv(i, j, k, j_dynadv_hor) + dff_h
+ delta_qv(i, j, k, j_dynadv_ver) = delta_qv(i, j, k, j_dynadv_ver) + dff_v
+ end if
+ enddo
+ enddo
+ ! end do
+ else
+ ! do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ dff_h = uairDY(i, j, k) * dxinv3(i, j) * fac43 * (&
+ 0.125 * (ffx(ip2(i), j, k) - ffx(im2(i), j, k)) &
+ - ffx(ip1(i), j, k) + ffx(im1(i), j, k)) &
+ + vairDY(i, j, k) * dyinv3(i, j) * fac43 * ( &
+ 0.125 * (ffx(i, jp2(j), k) - ffx(i, jm2(j), k)) &
+ - ffx(i, jp1(j), k) + ffx(i, jm1(j), k))
+ dff_v = WTxyz3(i, j, k)
+ dff = (dff_h + dff_v) * dtSlow
+ ffx(i, j, k) = ffx(i, j, k) + dff
+ if(iswater.and.track_water_dynadv) then
+ dff_h = dff_h * dtSlow
+ dff_v = dff_v * dtSlow
+ delta_qv(i, j, k, j_dynadv_hor) = delta_qv(i, j, k, j_dynadv_hor) + dff_h
+ delta_qv(i, j, k, j_dynadv_ver) = delta_qv(i, j, k, j_dynadv_ver) + dff_v
+ end if
+ enddo
+ enddo
+ ! end do
+ endif
+ ! +*** Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+ endif
+ endif
+ enddo
+
+ if(qqmass) then
+ ! +--Mass Conservation
+ ! + =================
+ do j = 1, my
+ do i = 1, mx
+ if(iswater.and.track_water_dynadv) then
+ delta_qv_tmp = ffx(i, j, k)
+ end if
+ ffx(i, j, k) = max(zero, ffx(i, j, k))
+ if(iswater.and.track_water_dynadv) then
+ delta_qv(i, j, k, j_dynadv_sav) = delta_qv(i, j, k, j_dynadv_sav) + ffx(i, j, k) - delta_qv_tmp
+ end if
+ ffo(i, j, k) = max(zero, ffo(i, j, k))
+ sumn = sumn + pstDYn(i, j) * dsigm1(k) * ffx(i, j, k)
+ summ = summ + opstDY(i, j) * dsigm1(k) * ffo(i, j, k)
+ enddo
+ enddo
+
+ !cCA fluxes at borders : difference between i = 1 and mx
+ ! ------------------------------------------------------
+ do j = 1, my
+ ! MARv<3
+ ! dtx = dt/dx
+ summ_tmp = dsigm1(k) * dtx * dsigm1(k) &
+ * (opstDY(1, j) * ffo(1, j, k) * uairDY(1, j, k) &
+ - opstDY(mx, j) * ffo(mx, j, k)* uairDY(mx, j, k))
+#if(AC)
+ ! to uncomment if not enough precipitation
+ !cCA : debug line above
+ summ_tmp = summ_tmp / dsigm1(k)
+#endif
+#if(EU)
+ ! to uncomment if not enough precipitation
+ summ_tmp = summ_tmp / dsigm1(k)
+#endif
+ summ = summ + summ_tmp
+ enddo
+ !cCA fluxes at borders : difference between j = 1 and my
+ ! ------------------------------------------------------
+ do i = 1, mx
+ ! MARv<3
+ ! dtx = dt/dx
+ summ_tmp = dsigm1(k) * dtx * dsigm1(k) &
+ * (opstDY(i, 1) * ffo(i, 1, k) * vairDY(i, 1, k) &
+ - opstDY(i, my)* ffo(i, my, k)* vairDY(i, my, k))
+#if(AC)
+ ! to uncomment if not enough precipitation
+ !cCA debug line above
+ summ_tmp = summ_tmp / dsigm1(k)
+#endif
+#if(EU)
+ ! to uncomment if not enough precipitation
+ summ_tmp = summ_tmp / dsigm1(k)
+#endif
+ summ = summ + summ_tmp
+ enddo
+ endif
+ endif
+ enddo
+ !$OMP END PARALLEL DO
+
+ if(sumn > zero .and. qqmass) then
+ summ = summ / sumn
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ if(iswater.and.track_water_dynadv) then
+ delta_qv_tmp = ffx(i, j, k)
+ end if
+ ffx(i, j, k) = summ * ffx(i, j, k)
+ if(iswater.and.track_water_dynadv) then
+ delta_qv(i, j, k, j_dynadv_sav) = delta_qv(i, j, k, j_dynadv_sav) + ffx(i, j, k) - delta_qv_tmp
+ end if
+ enddo
+ enddo
+ enddo
+ endif
+
+ deallocate (ffp1)
+ deallocate ( ffo)
+
+
+ return
+endsubroutine DYNadv_LFB_2p
diff --git a/MAR/code_mar/dynadv_sal.f90 b/MAR/code_mar/dynadv_sal.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4bae636690c44419fe03bf2dd3551d946cbefa33
--- /dev/null
+++ b/MAR/code_mar/dynadv_sal.f90
@@ -0,0 +1,99 @@
+#include "MAR_pp.def"
+subroutine DYNadv_sal
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW Tue 10-Jan-2012 MAR |
+ ! | subroutine DYNadv_sal includes the Horizontal Advection Contribution |
+ ! | of Saltating Snow |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ iterun: Run Iteration Counter |
+ ! | micphy: Cloud Microphysics Switch |
+ ! | openLB: Open Lateral Boundary Condition (LBC) Switch |
+ ! | |
+ ! | INPUT / uairDY,vairDY, qsHY, uss_HY |
+ ! | OUTPUT : snobSL : snow eroded thickness [m w.e.] |
+ ! | ^^^^^^^^ snohSL : snow precipitation thickness [m w.e.] |
+ ! | |
+ ! | METHOD : The following Contributions are taken into account: |
+ ! | ^^^^^^^^ dq/dt:=-(ud(qp*)/dx -vd(qp*)/dy)/p* |
+ ! | |
+ ! | REFER. : Alpert, thesis, 1980 |
+ ! | ^^^^^^^^ Pielke, Mesoscale Meteorological Modeling, 297--307, 1984 |
+ ! | Seibert and Morariu, JAM, p.118, 1991 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_hy
+ use mar_bs
+ use mar_sl
+ use mar_wk
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ real facFLX
+ common / DYNadv_sal_r / facFLX
+
+ if(iterun <= 1) then
+ ! if (zsigma(mz).LT.1.5)
+ ! . STOP ' in DYNadv_sal: z_sbl inacceptable'
+ ! facFLX=0.1+0.8*exp(-(zsigma(mz)-0.5)*0.15)
+ facFLX = 2.0 + 6.0 * exp(-(zsigma(mz) - 0.4) * 1.50) - 1.
+ endif
+
+ ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! Additional Snow Particles Horizontal Flux
+ ! =========================================
+
+ k = mz
+ ! k = mz (i.e., Consider SBL only)
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy0(i, j) = pstDY(i, j) &
+ * facFLX * qsHY(i, j, k) * min(unun, sign(unun, zero - uss_HY(i, j)))
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = WKxy0(i, j) * uairDY(i, j, k)
+ WKxy2(i, j) = WKxy0(i, j) * vairDY(i, j, k)
+ enddo
+ enddo
+
+ ! Flux Convergence
+ ! ================
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ qsHY(i, j, k) = qsHY(i, j, k) &
+ + (dtx * (WKxy1(im1(i), j) - WKxy1(ip1(i), j)) &
+ + dty * (WKxy2(i, jm1(j)) - WKxy2(i, jp1(j)))) &
+ / (2.0 * pstDY(i, j))
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy0(i, j) = 0.
+ WKxy1(i, j) = 0.
+ WKxy2(i, j) = 0.
+ enddo
+ enddo
+
+ ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ return
+endsubroutine DYNadv_sal
diff --git a/MAR/code_mar/dynadv_ver.f90 b/MAR/code_mar/dynadv_ver.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2e7c5a00a1354fc50cbd40bb07d9a8a70a4291b8
--- /dev/null
+++ b/MAR/code_mar/dynadv_ver.f90
@@ -0,0 +1,1360 @@
+#include "MAR_pp.def"
+subroutine DYNadv_ver
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW 18-09-2001 MAR |
+ ! | subroutine DYNadv_ver includes the Vertical Advection Contribution |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ iterun: Run Iteration Counter |
+ ! | uairDY, vairDY, pktaDY Values / Time Step n |
+ ! | uairDY : x-wind speed component (m/s) |
+ ! | vairDY : y-wind speed component (m/s) |
+ ! | pktaDY: potential temperature divided by 100.[kPa]**(R/Cp) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ uairDY, vairDY, pktaDY Values / Time Step n+1 |
+ ! | |
+ ! | METHOD: Unstaggered Grid: 1st Accurate in Space Upstream Scheme |
+ ! | ^^^^^^^^ Staggered Grid: 2nd Accurate in Space |
+ ! | |
+ ! | # OPTIONS: #VA: Vertical Average preferred in Centered Conserv Scheme |
+ ! | # ^^^^^^^^ #NS: NO Slip Surface BC used in Centered Conserv Scheme |
+ ! | # #UR: Upper Radiating Condition (to be corrected, DO'NT USE) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_wk
+#if(CA)
+ use mar_ca
+#endif
+
+ implicit none
+
+#if(UR)
+ real uairUP, vairUP, pktaUP
+ common / DYNadv_ver_var / uairUP(mx, my, 0:2), &
+ vairUP(mx, my, 0:2), &
+ pktaUP(mx, my, 0:2)
+#endif
+#if(WA)
+ integer nadvrd
+ common / DYNadv_ver_loc / nadvrd
+#endif
+ logical centrL
+#if(ZU)
+ logical adv3rd
+ real gat(mx, my, mz), ga0(mx, my)
+ data adv3rd/.true./
+#endif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer itimax, ntimax, nt__UP, nt, kk
+ real cflmax, cflsig, faccfl, dt__UP, dt_sig, dsgm
+ real uair_0, uair_c, uair_1, uair_2, uair_d
+ real vair_0, vair_c, vair_1, vair_2, vair_d
+ real pkta_0, pkta_c, pkta_1, pkta_2, pkta_d
+ real old__u, old__v, old__t
+
+ ! +--DATA
+ ! + ====
+
+ data centrL/.true./
+#if(UP)
+ centrL = .false.
+#endif
+
+ ! +--Initialization of the Upper Radiating Boundary Condition
+ ! + ========================================================
+#if(UR)
+ if(iterun == 1) then
+ do k = 0, 2
+ kk = max(1, k)
+ do j = jp11, my1
+ do i = ip11, mx1
+ uairUP(i, j, k) = uairDY(i, j, kk)
+ vairUP(i, j, k) = vairDY(i, j, kk)
+ pktaUP(i, j, k) = pktaDY(i, j, kk)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+
+ ! +--Slip condition for Mountain Wave Experiments
+ ! + ============================================
+#if(OM)
+ do j = jp11, my1
+ do i = ip11, mx1
+ psigDY(i, j, mz) = 0.0
+ enddo
+ enddo
+#endif
+
+ ! +--First and Second Order Schemes
+ ! + ==============================
+#if(ZU)
+ if(.not. adv3rd) then
+#endif
+
+ ! +--Courant Number
+ ! + --------------
+
+ cflmax = 0.0
+
+ ! +--Centered second Order Scheme on a staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(centrL .and. staggr) then
+
+#if(WA)
+ write(6, 6001) iterun
+6001 format(i6, ' 6001 centrL .and. staggr /CFL Number')
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = dt * psigDY(i, j, k) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz7(i, j, k) + WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, 1) = 0.00
+#if(UR)
+ WKxyz8(i, j, 1) = dt * psigDY(i, j, 1) * 0.33 &
+ / (pstDYn(i, j) * dsigm1(1) * 2.)
+ ! WKxyz8(i,j,1)<--"psigDY(i,j,0)"
+ cflsig = abs(WKxyz8(i, j, k) + WKxyz8(i, j, k))
+ cflmax = max(cflsig, cflmax)
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = dt * psigDY(i, j, km1(k)) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.)
+ cflsig = abs(WKxyz8(i, j, k) + WKxyz8(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ else
+
+ ! +--Upstream first Order Scheme on a staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(staggr) then
+
+#if(WA)
+ write(6, 6002) iterun
+6002 format(i6, ' 6002 .not. centrL .and. staggr /Wind Speed')
+#endif
+
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = (psigDY(i, j, k - 1) * dsig_1(k - 1) &
+ + psigDY(i, j, k) * dsig_1(k)) &
+ / (dsig_1(k - 1) + dsig_1(k))
+ enddo
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, 1) = psigDY(i, j, 1) * dsig_1(1) &
+ / (dsig_1(0) + dsig_1(1))
+ enddo
+ enddo
+
+ ! +--Upstream first Order Scheme on a non staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+#if(WA)
+ write(6, 6003) iterun
+6003 format(i6, ' 6003 (.not.)centrL.and. .not. staggr /Wind Speed')
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = psigDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ! +--Centered second Order Scheme on a non staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(centrL) then
+
+#if(WA)
+ write(6, 6004) iterun
+6004 format(i6, ' 6004 centrL.and. .not. staggr /CFL Number')
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = dt * WKxyz8(i, j, k) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.)
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ ! +--Upstream first Order Scheme on a (non) staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+#if(WA)
+ write(6, 6005) iterun
+6005 format(i6, ' 6005 .not. centrL.and.(.not.)staggr /CFL Number')
+#endif
+
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(WKxyz8(i, j, k) > 0.0) then
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k - 1))
+ else
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k))
+ endif
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(WKxyz8(i, j, k) > 0.0) then
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k - 1))
+ else
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k))
+ endif
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WKxyz7(i, j, 1) = 0.0
+ enddo
+ enddo
+
+ ! +--Work Array Reset
+ ! + ~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ endif
+
+ ! +--Set Up of the Local Split Time Differencing
+ ! + ----------------------------------------------
+
+ cflmax = 2.0 * cflmax
+ ! +... restricted CFL Criterion
+
+ ntimax = cflmax
+ if(centrL) then
+ ntimax = max(2, ntimax)
+#if(WA)
+ write(6, 6006) ntimax
+6006 format(i6, ' 6006 centrL.and.(.not.)staggr /Nb Iterat.')
+#endif
+ else
+ ntimax = max(1, ntimax)
+#if(WA)
+ write(6, 6007) ntimax
+6007 format(i6, ' 6007 .not. centrL.and.(.not.)staggr /Nb Iterat.')
+#endif
+ endif
+
+ ! +--Update of CFL Number
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ if(ntimax > 1) then
+ faccfl = 1.0 / ntimax
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = WKxyz7(i, j, k) * faccfl
+ WKxyz8(i, j, k) = WKxyz8(i, j, k) * faccfl
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! +--OUTPUT for Verification
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+#if(WA)
+ nadvrd = nadvrd + 1
+ write(6, 6000) nadvrd, cflmax, ntimax
+6000 format(i6, ' CFLmax ', 3x, ' ', 3x, ' =', f7.4, &
+ 6x, ' ntimax ', 8x, ' =', i4)
+#endif
+
+ ! +--2nd Order Centered Energy conserving: Local Split Time Differencing
+ ! + --------- (Haltiner & Williams 1980 7.2.2, (7-47b) p.220) ----------
+ ! + -----------------------------------------------
+
+ if(centrL) then
+
+ if(staggr) then
+
+#if(WA)
+ write(6, 6008)
+6008 format(6x, ' 6008 centrL.and. staggr /A Contrib.')
+#endif
+
+ do itimax = 1, ntimax
+
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+
+ do j = jp11, my1
+
+ ! +--Vertical Differences
+
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = uairDY(i, j, k)
+ WKxzq(i, k) = vairDY(i, j, k)
+ WKxzx(i, k) = pktaDY(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (uairDY(i, j, k) * dsigm1(k) * 2.0 &
+ + uairDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (vairDY(i, j, k) * dsigm1(k) * 2.0 &
+ + vairDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (pktaDY(i, j, k) * dsigm1(k) * 2.0 &
+ + pktaDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ uair_0 = WKxzp(i, k)
+#if(UR)
+ uair_0 = uairUP(i, j, 0)
+#endif
+ WKxza(i, k) = (WKxzp(i, k) - uair_0)
+ vair_0 = WKxzq(i, k)
+#if(UR)
+ vair_0 = vairUP(i, j, 0)
+#endif
+ WKxzb(i, k) = (WKxzq(i, k) - vair_0)
+ pkta_0 = WKxzx(i, k)
+#if(UR)
+ pkta_0 = pktaUP(i, j, 0)
+#endif
+ WKxzc(i, k) = (WKxzx(i, k) - pkta_0)
+ enddo
+
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = uairDY(i, j, k)
+ WKxzq(i, k) = vairDY(i, j, k)
+ WKxzx(i, k) = pktaDY(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (uairDY(i, j, k - 1) * dsigm1(k - 1) &
+ + uairDY(i, j, k) * dsigm1(k) * 2.0 &
+ + uairDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (vairDY(i, j, k - 1) * dsigm1(k - 1) &
+ + vairDY(i, j, k) * dsigm1(k) * 2.0 &
+ + vairDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (pktaDY(i, j, k - 1) * dsigm1(k - 1) &
+ + pktaDY(i, j, k) * dsigm1(k) * 2.0 &
+ + pktaDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = uairDY(i, j, k)
+ WKxzq(i, k) = vairDY(i, j, k)
+ WKxzx(i, k) = pktaDY(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (uairDY(i, j, k - 1) * dsigm1(k - 1) &
+ + uairDY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (vairDY(i, j, k - 1) * dsigm1(k - 1) &
+ + vairDY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (pktaDY(i, j, k - 1) * dsigm1(k - 1) &
+ + pktaDY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (pktaDY(i, j, k) - WKxzx(i, k - 1))
+#endif
+ enddo
+
+ ! +--Advection Contribution
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ WKxyz1(i, j, k) = uairDY(i, j, k) - WKxzd(i, k)
+ WKxyz4(i, j, k) = uairDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ WKxyz2(i, j, k) = vairDY(i, j, k) - WKxzd(i, k)
+ WKxyz5(i, j, k) = vairDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = pktaDY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = pktaDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ WKxyz1(i, j, k) = uairDY(i, j, k) - WKxzd(i, k)
+ WKxyz4(i, j, k) = uairDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ WKxyz2(i, j, k) = vairDY(i, j, k) - WKxzd(i, k)
+ WKxyz5(i, j, k) = vairDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = pktaDY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = pktaDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+
+ enddo
+
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+
+ ! +--Vertical Differences
+
+ do j = jp11, my1
+
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ uair_0 = WKxzp(i, k)
+#if(UR)
+ uair_0 = uairUP(i, j, 0)
+#endif
+ WKxza(i, k) = (WKxzp(i, k) - uair_0)
+ vair_0 = WKxzq(i, k)
+#if(UR)
+ vair_0 = vairUP(i, j, 0)
+#endif
+ WKxzb(i, k) = (WKxzq(i, k) - vair_0)
+ pkta_0 = WKxzx(i, k)
+#if(UR)
+ pkta_0 = pktaUP(i, j, 0)
+#endif
+ WKxzc(i, k) = (WKxzx(i, k) - pkta_0)
+ enddo
+
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (pktaDY(i, j, k) - WKxzx(i, k - 1))
+#endif
+ enddo
+
+ ! +--Advection Contribution
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+
+ enddo
+
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+ do j = jp11, my1
+
+ ! +--Vertical Differences
+
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ uair_0 = WKxzp(i, k)
+#if(UR)
+ uair_0 = uairUP(i, j, 0)
+#endif
+ WKxza(i, k) = (WKxzp(i, k) - uair_0)
+ vair_0 = WKxzq(i, k)
+#if(UR)
+ vair_0 = vairUP(i, j, 0)
+#endif
+ WKxzb(i, k) = (WKxzq(i, k) - vair_0)
+ pkta_0 = WKxzx(i, k)
+#if(UR)
+ pkta_0 = pktaUP(i, j, 0)
+#endif
+ WKxzc(i, k) = (WKxzx(i, k) - pkta_0)
+ enddo
+
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (pktaDY(i, j, k) - WKxzx(i, k - 1))
+#endif
+ enddo
+
+ ! +--Wind Advection
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+ uairDY(i, j, k) = WKxyz1(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k))
+ vairDY(i, j, k) = WKxyz2(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k))
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ uairDY(i, j, k) = WKxyz1(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k))
+ vairDY(i, j, k) = WKxyz2(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k))
+ enddo
+
+ ! +--Pot.Temp.Advect.avoids double Counting in case of convective Adjustment
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ pktaDY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ pktaDY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+#if(cA)
+ endif
+#endif
+ enddo
+
+ enddo
+
+ endif
+
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+
+ enddo
+
+ ! +--2nd Order Centered Leap-Frog Backward: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+
+ else
+
+#if(WA)
+ write(6, 6009)
+6009 format(6x, ' 6009 centrL.and. .not. staggr /A Contrib.')
+#endif
+
+ do itimax = 1, ntimax
+
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+
+ do j = jp11, my1
+
+ ! +--Advection Increment
+
+ k = 1
+ do i = ip11, mx1
+ uair_0 = uairDY(i, j, k)
+#if(UR)
+ uair_0 = uairUP(i, j, 0)
+#endif
+ WKxza(i, k) = (uairDY(i, j, k + 1) - uair_0) &
+ * WKxyz7(i, j, k)
+ vair_0 = vairDY(i, j, k)
+#if(UR)
+ vair_0 = vairUP(i, j, 0)
+#endif
+ WKxzb(i, k) = (vairDY(i, j, k + 1) - vairDY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ pkta_0 = pktaDY(i, j, k)
+#if(UR)
+ pkta_0 = pktaUP(i, j, 0)
+#endif
+ WKxzc(i, k) = (pktaDY(i, j, k + 1) - pktaDY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (uairDY(i, j, k + 1) - uairDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (vairDY(i, j, k + 1) - vairDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (pktaDY(i, j, k + 1) - pktaDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -uairDY(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -vairDY(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (pktaDY(i, j, k + 1) - pktaDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+
+ ! +--Advection Contribution
+
+ do k = 1, mmz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = uairDY(i, j, k) - WKxza(i, k)
+ WKxyz4(i, j, k) = uairDY(i, j, k) - (WKxza(i, k) + WKxza(i, k))
+ WKxyz2(i, j, k) = vairDY(i, j, k) - WKxzb(i, k)
+ WKxyz5(i, j, k) = vairDY(i, j, k) - (WKxzb(i, k) + WKxzb(i, k))
+ WKxyz3(i, j, k) = pktaDY(i, j, k) - WKxzc(i, k)
+ WKxyz6(i, j, k) = pktaDY(i, j, k) - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ enddo
+
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+
+ ! +--Advection Increment
+
+ do j = jp11, my1
+
+ k = 1
+ do i = ip11, mx1
+ uair_0 = WKxyz4(i, j, k)
+#if(UR)
+ uair_0 = uairUP(i, j, 0)
+#endif
+ vair_0 = WKxyz5(i, j, k)
+#if(UR)
+ vair_0 = vairUP(i, j, 0)
+#endif
+ pkta_0 = WKxyz6(i, j, k)
+#if(UR)
+ pkta_0 = pktaUP(i, j, 0)
+#endif
+
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - uair_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - vair_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - pkta_0) &
+ * WKxyz7(i, j, k)
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (pktaDY(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+
+ ! +--Advection Contribution
+
+ do k = 1, mmz
+ do i = ip11, mx1
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxza(i, k) + WKxza(i, k))
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzb(i, k) + WKxzb(i, k))
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+
+ enddo
+
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+ do j = jp11, my1
+
+ ! +--Advection Increment
+
+ k = 1
+ do i = ip11, mx1
+ uair_0 = WKxyz4(i, j, k)
+#if(UR)
+ uair_0 = uairUP(i, j, 0)
+#endif
+ vair_0 = WKxyz5(i, j, k)
+#if(UR)
+ vair_0 = vairUP(i, j, 0)
+#endif
+ pkta_0 = WKxyz6(i, j, k)
+#if(UR)
+ pkta_0 = pktaUP(i, j, 0)
+#endif
+
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - uair_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - vair_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - pkta_0) &
+ * WKxyz7(i, j, k)
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (pktaDY(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+
+ ! +--Wind Advection
+
+ do k = 1, mmz
+ do i = ip11, mx1
+ uairDY(i, j, k) = WKxyz1(i, j, k) - WKxza(i, k)
+ vairDY(i, j, k) = WKxyz2(i, j, k) - WKxzb(i, k)
+ enddo
+
+ ! +--Pot.Temp.Advect.avoids double Counting in case of convective Adjustment
+
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ pktaDY(i, j, k) = WKxyz3(i, j, k) - WKxzc(i, k)
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+
+ enddo
+
+ endif
+
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+
+ enddo
+
+ endif
+
+ ! +--First Order Upstream Scheme: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+
+ else
+
+#if(WA)
+ write(6, 6010)
+6010 format(6x, ' 6010 .not. centrL.and.(.not.)staggr /A Contrib.')
+#endif
+
+ do itimax = 1, ntimax
+
+ ! +--Auxiliary Variables
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(WA)
+ write(6, 6011) itimax, WKxyz1(imez, jmez, mz1), WKxyz1(imez, jmez, mz) &
+ , uairDY(imez, jmez, mz1), uairDY(imez, jmez, mz)
+6011 format(6x, ' 6011 .not. centrL.and.(.not.)staggr /A Contrib.', &
+ 4f9.6)
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = uairDY(i, j, k)
+ WKxyz2(i, j, k) = vairDY(i, j, k)
+ WKxyz3(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Vertical Differences
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ k = 1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = 0.0d+0
+ WKxyz5(i, j, k) = 0.0d+0
+ WKxyz6(i, j, k) = 0.0d+0
+#if(UR)
+ WKxyz4(i, j, k) = WKxyz1(i, j, k) - uairUP(i, j, 0)
+ WKxyz5(i, j, k) = WKxyz2(i, j, k) - vairUP(i, j, 0)
+ WKxyz6(i, j, k) = WKxyz3(i, j, k) - pktaUP(i, j, 0)
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz1(i, j, k) - WKxyz1(i, j, k - 1)
+ WKxyz5(i, j, k) = WKxyz2(i, j, k) - WKxyz2(i, j, k - 1)
+ WKxyz6(i, j, k) = WKxyz3(i, j, k) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ enddo
+
+ k = mzz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxy1(i, j) = -WKxyz1(i, j, k - 1)
+ WKxy2(i, j) = -WKxyz2(i, j, k - 1)
+ WKxy3(i, j) = pktaDY(i, j, k) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = uairDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k + 1)
+ WKxyz2(i, j, k) = vairDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k + 1)
+ WKxyz3(i, j, k) = pktaDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k + 1)
+ enddo
+ enddo
+ enddo
+
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = uairDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy1(i, j)
+ WKxyz2(i, j, k) = vairDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy2(i, j)
+ WKxyz3(i, j, k) = pktaDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy3(i, j)
+ enddo
+ enddo
+
+ ! +--Wind Update
+ ! + ~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ uairDY(i, j, k) = WKxyz1(i, j, k)
+ vairDY(i, j, k) = WKxyz2(i, j, k)
+ enddo
+
+ ! +--Pot.Temp.Update avoids double Counting in case of convective Adjustment
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ pktaDY(i, j, k) = WKxyz3(i, j, k)
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+ enddo
+
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+#if(WA)
+ write(6, 6012) itimax, WKxyz1(imez, jmez, mz1), WKxyz1(imez, jmez, mz) &
+ , uairDY(imez, jmez, mz1), uairDY(imez, jmez, mz)
+6012 format(6x, ' 6012 .not. centrL.and.(.not.)staggr /A Contrib.', &
+ 4f9.6)
+#endif
+ enddo
+
+ endif
+
+#if(UR)
+ ! Upper Radiating Boundary Condition
+ ! ----------------------------------
+ do j = jp11, my1
+ do i = ip11, mx1
+ uair_c = zero
+ uair_1 = (uairDY(i, j, 1) + uairUP(i, j, 1)) * 0.5
+ uair_2 = (uairDY(i, j, 2) + uairUP(i, j, 2)) * 0.5
+ uair_d = uair_2 - uair_1
+ if(uair_d /= zero) &
+ uair_c = -(uairDY(i, j, 1) - uairUP(i, j, 1)) * dsig_1(1) / (dt * uair_d)
+ if(uair_c < zero) then
+ dt__UP = -sigma(1) / uair_c
+ nt__UP = dt / dt__UP
+ nt__UP = max(1, nt__UP)
+ dt__UP = dt / nt__UP
+ dt_sig = dt__UP * uair_c / sigma(1)
+ do nt = 1, nt__UP
+ uairUP(i, j, 0) = uairUP(i, j, 0) &
+ - (uair_1 - uairUP(i, j, 0)) * dt_sig
+ enddo
+ endif
+ do k = 1, 2
+ uairUP(i, j, k) = uairDY(i, j, k)
+ enddo
+ vair_c = zero
+ vair_1 = (vairDY(i, j, 1) + vairUP(i, j, 1)) * 0.5
+ vair_2 = (vairDY(i, j, 2) + vairUP(i, j, 2)) * 0.5
+ vair_d = vair_2 - vair_1
+ if(vair_d /= zero) &
+ vair_c = -(vairDY(i, j, 1) - vairUP(i, j, 1)) * dsig_1(1) / (dt * vair_d)
+ if(vair_c < zero) then
+ dt__UP = -sigma(1) / vair_c
+ nt__UP = dt / dt__UP
+ nt__UP = max(1, nt__UP)
+ dt__UP = dt / nt__UP
+ dt_sig = dt__UP * vair_c / sigma(1)
+ do nt = 1, nt__UP
+ vairUP(i, j, 0) = vairUP(i, j, 0) &
+ - (vair_1 - vairUP(i, j, 0)) * dt_sig
+ enddo
+ endif
+ do k = 1, 2
+ vairUP(i, j, k) = vairDY(i, j, k)
+ enddo
+ pkta_c = zero
+ pkta_1 = (pktaDY(i, j, 1) + pktaUP(i, j, 1)) * 0.5
+ pkta_2 = (pktaDY(i, j, 2) + pktaUP(i, j, 2)) * 0.5
+ pkta_d = pkta_2 - pkta_1
+ if(pkta_d /= zero) &
+ pkta_c = -(pktaDY(i, j, 1) - pktaUP(i, j, 1)) * dsig_1(1) / (dt * pkta_d)
+ if(pkta_c < zero) then
+ dt__UP = -sigma(1) / pkta_c
+ nt__UP = dt / dt__UP
+ nt__UP = max(1, nt__UP)
+ dt__UP = dt / nt__UP
+ dt_sig = dt__UP * pkta_c / sigma(1)
+ do nt = 1, nt__UP
+ pktaUP(i, j, 0) = pktaUP(i, j, 0) &
+ - (pkta_1 - pktaUP(i, j, 0)) * dt_sig
+ enddo
+ endif
+ do k = 1, 2
+ pktaUP(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+
+ ! +--Work Arrays Reset
+ ! + -----------------
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ enddo
+ enddo
+
+ do k = 1, mz
+ do i = 1, mx
+ WKxza(i, k) = 0.0
+ WKxzb(i, k) = 0.0
+ WKxzc(i, k) = 0.0
+ WKxzd(i, k) = 0.0
+ WKxzp(i, k) = 0.0
+ WKxzq(i, k) = 0.0
+ WKxzx(i, k) = 0.0
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+
+ ! +--Third Order Vertical Scheme
+ ! + ===========================
+#if(ZU)
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = 0.0
+#endif
+#if(ZO)
+ ga0(i, j) = uairDY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = uairDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ uairDY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+#if(ZO)
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = vairDY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = vairDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ vairDY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = pktaDY(i, j, mzz)
+#endif
+#if(ZO)
+ ga0(i, j) = pktaDY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ pktaDY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+ return
+endsubroutine DYNadv_ver
diff --git a/MAR/code_mar/dynadv_verq.f90 b/MAR/code_mar/dynadv_verq.f90
new file mode 100644
index 0000000000000000000000000000000000000000..99a93d125515ace3e2e9acf22de4e14a3603bfde
--- /dev/null
+++ b/MAR/code_mar/dynadv_verq.f90
@@ -0,0 +1,985 @@
+#include "MAR_pp.def"
+subroutine DYNadv_verq
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW 18-09-2001 MAR |
+ ! | subroutine DYNadv_verq includes the Vertical Advection Contribution |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ iterun, Run Iteration Counter |
+ ! | qvDY, Air Vap. Water Values / Time Step n |
+ ! | qvapSL, SBC Vap. Water Values / Time Step n |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ qvDY, Air Vap. Water Values / Time Step n+1 |
+ ! | |
+ ! | METHOD: Unstaggered Grid: 1st Accurate in Space Upstream Scheme |
+ ! | ^^^^^^^^ Staggered Grid: 2nd Accurate in Space |
+ ! | |
+ ! | # OPTIONS: #VA: Vertical Average preferred in Centered Conserv Scheme |
+ ! | # ^^^^^^^^ #NS: NO Slip Surface BC used in Centered Conserv Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_sl
+ use mar_wk
+#if(cA)
+ use mar_ca
+#endif
+ ! +
+ implicit none
+ ! +
+#if(WA)
+ integer nadvrd
+ common / DYNadv_ver_loc / nadvrd
+ ! +
+#endif
+ logical centrL
+#if(ZU)
+ logical adv3rd
+ real gat(mx, my, mz), ga0(mx, my)
+ data adv3rd/.true./
+#endif
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer i, j, k, m
+ integer itimax, ntimax
+ real cflmax, cflsig, faccfl, dsgm, qv_0
+ real old__u, old__v, old__t, qw_0, qr_0
+ ! +
+ ! +
+ ! +--DATA
+ ! + ====
+ ! +
+ ! +
+ data centrL/.true./
+#if(UP)
+ centrL = .false.
+#endif
+ ! +
+ ! +
+ ! +--Slip condition for Mountain Wave Experiments
+ ! + ============================================
+ ! +
+#if(OM)
+ do j = jp11, my1
+ do i = ip11, mx1
+ psigDY(i, j, mz) = 0.0
+ enddo
+ enddo
+#endif
+ ! +
+ ! +
+ ! +--First and Second Order Schemes
+ ! + ==============================
+ ! +
+#if(ZU)
+ if(.not. adv3rd) then
+#endif
+ ! +
+ ! +
+ ! +--Courant Number
+ ! + --------------
+ ! +
+ cflmax = 0.0
+ ! +
+ ! +--Centered second Order Scheme on a staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(centrL .and. staggr) then
+ ! +
+#if(WA)
+ write(6, 6001) iterun
+6001 format(i6, ' 6001 centrL .and. staggr /CFL Number')
+#endif
+ ! +
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = dt * psigDY(i, j, k) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz7(i, j, k) + WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+ ! +
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, 1) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = dt * psigDY(i, j, km1(k)) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz8(i, j, k) + WKxyz8(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+ ! +
+ else
+ ! +
+ ! +--Upstream first Order Scheme on a staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(staggr) then
+ ! +
+#if(WA)
+ write(6, 6002) iterun
+6002 format(i6, ' 6002 .not. centrL .and. staggr /Wind Speed')
+#endif
+ ! +
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = (psigDY(i, j, k - 1) * dsig_1(k - 1) &
+ + psigDY(i, j, k) * dsig_1(k)) &
+ / (dsig_1(k - 1) + dsig_1(k))
+ enddo
+ enddo
+ enddo
+ ! +
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, 1) = psigDY(i, j, 1) * dsig_1(1) &
+ / (dsig_1(0) + dsig_1(1))
+ enddo
+ enddo
+ ! +
+ ! +--Upstream first Order Scheme on a non staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+#if(WA)
+ write(6, 6003) iterun
+6003 format(i6, ' 6003 (.not.)centrL.and. .not. staggr /Wind Speed')
+#endif
+ ! +
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = psigDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ endif
+ ! +
+ ! +--Centered second Order Scheme on a non staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(centrL) then
+ ! +
+#if(WA)
+ write(6, 6004) iterun
+6004 format(i6, ' 6004 centrL.and. .not. staggr /CFL Number')
+#endif
+ ! +
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = dt * WKxyz8(i, j, k) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Upstream first Order Scheme on a (non) staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+#if(WA)
+ write(6, 6005) iterun
+6005 format(i6, ' 6005 .not. centrL.and.(.not.)staggr /CFL Number')
+#endif
+ ! +
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(WKxyz8(i, j, k) > 0.0) then
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k - 1))
+ else
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k))
+ endif
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(WKxyz8(i, j, k) > 0.0) then
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k - 1))
+ else
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k))
+ endif
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxyz7(i, j, 1) = 0.0
+ enddo
+ enddo
+ ! +
+ ! +--Work Array Reset
+ ! + ~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ ! +
+ endif
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Set Up of the Local Split Time Differencing
+ ! + ----------------------------------------------
+ ! +
+ cflmax = 2.0 * cflmax
+ ! +... restricted CFL Criterion
+ ! +
+ ntimax = cflmax
+ if(centrL) then
+ ntimax = max(2, ntimax)
+#if(WA)
+ write(6, 6006) ntimax
+6006 format(i6, ' 6006 centrL.and.(.not.)staggr /Nb Iterat.')
+#endif
+ else
+ ntimax = max(1, ntimax)
+#if(WA)
+ write(6, 6007) ntimax
+6007 format(i6, ' 6007 .not. centrL.and.(.not.)staggr /Nb Iterat.')
+#endif
+ endif
+ ! +
+ ! +--Update of CFL Number
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ if(ntimax > 1) then
+ faccfl = 1.0d+0 / ntimax
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = WKxyz7(i, j, k) * faccfl
+ WKxyz8(i, j, k) = WKxyz8(i, j, k) * faccfl
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+ ! +--OUTPUT for Verification
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+#if(WA)
+ nadvrd = nadvrd + 1
+ write(6, 6000) nadvrd, cflmax, ntimax
+6000 format(i6, ' CFLmax ', 3x, ' ', 3x, ' =', f7.4, &
+ 6x, ' ntimax ', 8x, ' =', i4)
+#endif
+ ! +
+ ! +
+ ! +--2nd Order Centered Energy conserving: Local Split Time Differencing
+ ! + --------- (Haltiner & Williams 1980 7.2.2, (7-47b) p.220) ----------
+ ! + -----------------------------------------------
+ ! +
+ if(centrL) then
+ ! +
+ if(staggr) then
+ ! +
+#if(WA)
+ write(6, 6008)
+6008 format(6x, ' 6008 centrL.and. staggr /A Contrib.')
+#endif
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Vertical Differences
+ ! +
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzx(i, k) = qvDY(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (qvDY(i, j, k) * dsigm1(k) * 2.0 &
+ + qvDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ qv_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qv_0)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzx(i, k) = qvDY(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (qvDY(i, j, k - 1) * dsigm1(k - 1) &
+ + qvDY(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + qvDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzx(i, k) = qvDY(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (qvDY(i, j, k - 1) * dsigm1(k - 1) &
+ + qvDY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ ! +
+ k = mzz
+ do i = ip11, mx1
+ WKxy3(i, j) = 0.0
+#if(NS)
+ WKxy3(i, j) = (qvapSL(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = qvDY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = qvDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = qvDY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = qvDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+ ! +
+ ! +--Vertical Differences
+ ! +
+ do j = jp11, my1
+ ! +
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ qv_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qv_0)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ ! +
+ k = mzz
+ do i = ip11, mx1
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy3(i, j) = (qvapSL(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Vertical Differences
+ ! +
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ qv_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qv_0)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ ! +
+ k = mzz
+ do i = ip11, mx1
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy3(i, j) = (qvapSL(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+ ! +
+ ! +--Wat.Vapr.Advect.avoids double Counting in case of convective Adjustment
+ ! +
+ do k = 1, mmz1
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+#if(cA)
+ endif
+#endif
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ enddo
+ ! +
+ ! +
+ ! +--2nd Order Centered Leap-Frog Backward: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ else
+ ! +
+#if(WA)
+ write(6, 6009)
+6009 format(6x, ' 6009 centrL.and. .not. staggr /A Contrib.')
+#endif
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Advection Increment
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qv_0 = qvDY(i, j, k)
+ WKxzc(i, k) = (qvDY(i, j, k + 1) - qvDY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxzc(i, k) = (qvDY(i, j, k + 1) - qvDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxzc(i, k) = (qvapSL(i, j) - qvDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ WKxyz3(i, j, k) = qvDY(i, j, k) - WKxzc(i, k)
+ WKxyz6(i, j, k) = qvDY(i, j, k) - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+ ! +
+ ! +--Advection Increment
+ ! +
+ do j = jp11, my1
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qw_0 = WKxyz4(i, j, k)
+ qr_0 = WKxyz5(i, j, k)
+ qv_0 = WKxyz6(i, j, k)
+ ! +
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - qw_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - qr_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - qv_0) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qvapSL(i, j) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxza(i, k) + WKxza(i, k))
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzb(i, k) + WKxzb(i, k))
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Advection Increment
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qw_0 = WKxyz4(i, j, k)
+ qr_0 = WKxyz5(i, j, k)
+ qv_0 = WKxyz6(i, j, k)
+ ! +
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - qw_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - qr_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - qv_0) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qvapSL(i, j) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Wat.Vapr.Advect.avoids double Counting in case of convective Adjustment
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k) - WKxzc(i, k)
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--First Order Upstream Scheme: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ else
+ ! +
+#if(WA)
+ write(6, 6010)
+6010 format(6x, ' 6010 .not. centrL.and.(.not.)staggr /A Contrib.')
+#endif
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--Auxiliary Variables
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(WA)
+ write(6, 6011) itimax, WKxyz1(imez, jmez, mz1), WKxyz1(imez, jmez, mz) &
+ , qvDY(imez, jmez, mz1), qvDY(imez, jmez, mz)
+#endif
+6011 format(6x, ' 6011 .not. centrL.and.(.not.)staggr /A Contrib.', &
+ 4f9.6)
+ ! +
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz3(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Vertical Differences
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ k = 1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = 0.0d+0
+ WKxyz5(i, j, k) = 0.0d+0
+ WKxyz6(i, j, k) = 0.0d+0
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz1(i, j, k) - WKxyz1(i, j, k - 1)
+ WKxyz5(i, j, k) = WKxyz2(i, j, k) - WKxyz2(i, j, k - 1)
+ WKxyz6(i, j, k) = WKxyz3(i, j, k) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mzz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxy1(i, j) = -WKxyz1(i, j, k - 1)
+ WKxy2(i, j) = -WKxyz2(i, j, k - 1)
+ WKxy3(i, j) = qvapSL(i, j) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz3(i, j, k) = qvDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k + 1)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz3(i, j, k) = qvDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy3(i, j)
+ enddo
+ enddo
+ ! +
+ ! +--Wat.Vapr.Update avoids double Counting in case of convective Adjustment
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k)
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+#if(WA)
+ write(6, 6012) itimax, WKxyz1(imez, jmez, mz1), WKxyz1(imez, jmez, mz) &
+ , qvDY(imez, jmez, mz1), qvDY(imez, jmez, mz)
+6012 format(6x, ' 6012 .not. centrL.and.(.not.)staggr /A Contrib.', &
+ 4f9.6)
+#endif
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Work Arrays Reset
+ ! + -----------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do i = 1, mx
+ WKxza(i, k) = 0.0
+ WKxzb(i, k) = 0.0
+ WKxzc(i, k) = 0.0
+ WKxzd(i, k) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Third Order Vertical Scheme
+ ! + ===========================
+ ! +
+#if(ZU)
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = qvapSL(i, j)
+#endif
+#if(ZO)
+ ga0(i, j) = qvDY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qvDY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+ return
+endsubroutine DYNadv_verq
diff --git a/MAR/code_mar/dyndgz.f90 b/MAR/code_mar/dyndgz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..076dc0ccac19e7ce17c978f0f7ba4180281c7bd9
--- /dev/null
+++ b/MAR/code_mar/dyndgz.f90
@@ -0,0 +1,672 @@
+#include "MAR_pp.def"
+subroutine dyndgz_mp(norder)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FAST 15-04-2021 MAR |
+ ! | subroutine DYNdgz includes in the Horizontal Momentum Equations |
+ ! | the terms representing the Pressure Gradient Force (PGF) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ brocam: Brown and Campana Time Scheme Switch |
+ ! | itFast: Short Time Step Counter |
+ ! | |
+ ! | uairDY, vairDY, pktaDY : u, v, and P / Time Step n |
+ ! | ubefDY, vbefDY, ddux,ddvx: u, v / Time Step n-1, n-2 |
+ ! | uairDY: x-wind speed component (m/s) |
+ ! | vairDY: y-wind speed component (m/s) |
+ ! | pktaDY: potential temperature divided by 100.[kPa]**(R/Cp) |
+ ! | virDY: Contribution from Air Loading (kg/kg) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ uairDY, vairDY, pktaDY: u, v, and P Values / Time Step n+1 |
+ ! | gpmiDY(i,j,k) = g * z (i,j,k-1/2), (Geopotential) (m2/s2) |
+ ! | |
+ ! | METHOD: 1) Solves the Hydrostatic Relation: |
+ ! | ^^^^^^ 0 =- 1 /rho -dPHI/dp |
+ ! | => gives the Geopotential PHI between Sigma Levels|
+ ! | 2) Solves the Contributions : |
+ ! | du/dt:= -dPHI/dx |
+ ! | dv/dt:= -dPHI/dy |
+ ! | 3) Spatial Numerical Scheme : |
+ ! | Spatial Discretisation on Arakawa A Grid |
+ ! | norder.EQ.2 2th Order Accurate Horizontal Spatial Differencing .OR. |
+ ! | norder.NE.2 4th Order Accurate Horizontal Spatial Differencing |
+ ! | dPHI/dx and dPHI/dy are computed on p**(R/Cp) Surfaces |
+ ! | 4) Temporal Numerical Scheme : |
+ ! | Time Split (i.e. each contribution computed separately) |
+ ! | Split Time Differencing, i.e. pressure Evolution and |
+ ! | PGF are computed on Short Time Step dtfast=dt/(ntFast+1)|
+ ! | Advection and Diffusion are Computed on a Longer One) |
+ ! | Brown and Campana Time Scheme used over Short Time Step |
+ ! | |
+ ! | REFER.: 1) Purser and Leslie, MWR 116, 2069--2080, 1988 (A Grid)|
+ ! | ^^^^^^ 2) Marchuk, Numer.Meth.in Weath.Predict., 1974 (Time Split)|
+ ! | 3) Gadd, QJRMS 104, 569--582, 1978 (Split Time Differencing)|
+ ! | 4) Brown and Campana, MWR 106, 1125--1136, 1978 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_ub
+ use mar_wk
+ use marvec
+
+ use trackwind, only : track_dgz, delta_u_dgz, delta_v_dgz, &
+ i_dgzadv, i_dgzpgf, itw, ntrackdgz, &
+ dudt_t, dudt_tm1, c1a_t, c1a_tm1, c1a_tm2
+
+ implicit none
+
+ integer norder
+ integer i, j, k, m
+
+ ! +--Local Variables
+ ! + ================
+
+ ! WTxyz1 : Advected u-Momentum
+ !real WTxyz1(mx, my, mz)
+ ! WTxyz2 : Advected v-Momentum
+ !real WTxyz2(mx, my, mz)
+
+ real bca, bcb, c1a, c1b, ddux, ddvx, fraCLS, sigCLS
+ real Raylei
+
+ ! +--DATA
+ ! + ====
+ ! +...Parameters of the Brown-Campana (1978, MWR, p.1125) scheme
+ ! + WARNING : scheme is unstable for bca maximum value (0.25)
+ data bca/0.245e0/, bcb/0.510e0/
+
+ ! +--Contributions from Momentum Advection
+ ! + =====================================
+
+ ! + **********
+ call DYNadv_dLF_mp(norder, uairDY, vairDY, WTxyz1, WTxyz2)
+ ! + **********
+
+ ! +--Integration of the Hydrostatic Equation
+ ! + =======================================
+
+ ! +--EXNER Potential
+ ! + ---------------
+
+ if(brocam) then
+ do j = 1, my
+ do i = 1, mx
+ WKxy4(i, j) = exp(cap * log(pstDYn(i, j) + ptopDY))
+ WKxy1(i, j) = cp * WKxy4(i, j)
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ WKxy4(i, j) = exp(cap * log(pstDY(i, j) + ptopDY))
+ WKxy1(i, j) = cp * WKxy4(i, j)
+ enddo
+ enddo
+
+ endif
+
+ ! +--Surface Contribution to Exner Function
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! fraCLS : CLS Fraction where Temperature~Surface Temperature
+ ! 0<fraCLS<1 and generally close to zero
+ ! fraCLS = 0.5 ==> linear variation of potential Temperature
+ ! is assumed beween levels k=mz and k=mzz
+ fraCLS = 0.0d+0
+#if(IL)
+ fraCLS = 0.5d+0
+#endif
+ ! +
+ sigCLS = (1.0d+0 - fraCLS) + fraCLS * sigma(mz)
+
+ if(brocam) then
+ do j = 1, my
+ do i = 1, mx
+ WKxy5(i, j) = cp * exp(cap * log(pstDYn(i, j) * sigCLS + ptopDY))
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ WKxy5(i, j) = cp * exp(cap * log(pstDY(i, j) * sigCLS + ptopDY))
+ enddo
+ enddo
+ endif
+
+ ! +--Atmospheric Contribution to Exner Function
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ !$OMP PARALLEL do private (i,j,k)
+ do j = 1, my
+ do k = 1, mz
+ if(k >= mz .and. ptopDY <= 0.0) then
+ ! do j=1,my
+ do i = 1, mx
+ WKxy3(i, j) = 0.0
+ enddo
+ ! end do
+ else
+ if(brocam) then
+ ! do j=1,my
+ do i = 1, mx
+ WKxy3(i, j) = exp(cap * log(pstDYn(i, j) * sigmid(mzz - k) + ptopDY))
+ enddo
+ ! end do
+ else
+ ! do j=1,my
+ do i = 1, mx
+ WKxy3(i, j) = exp(cap * log(pstDY(i, j) * sigmid(mzz - k) + ptopDY))
+ enddo
+ ! end do
+ endif
+ endif
+
+ ! do j=1,my
+ do i = 1, mx
+ WKxy2(i, j) = cp * WKxy3(i, j)
+ ! WKxyz4 : p ** (R/Cp)
+ WKxyz4(i, j, mzz - k) = WKxy3(i, j)
+ enddo
+ ! end do
+
+ ! +--GEO---Potential (Mid Layer k-1/2)
+ ! + ---------------
+
+ if (k==1) then
+ ! +--Of the Surface Layer
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ ! do j=1,my
+ do i = 1, mx
+ ! REMARK : It is assumed that the Geopotential Difference
+ ! in Lower Layer depends only on pktaDY at 1st Sigma Lev.
+ ! gpmiDY(mz) = gplvDY(mzz) + Cp * Delta[P**(R/Cp)] * [Theta/P0**(R/Cp)]
+ ! = gpmiDY_surf + Cp * Delta T
+ gpmiDY(i, j, mz) = gplvDY(i, j, mzz) &
+ + ((WKxy5(i, j) - WKxy2(i, j)) * pktaDY(i, j, mz) &
+ + (WKxy1(i, j) - WKxy5(i, j)) * pktaDY(i, j, mzz)) &
+ * (1.0 + virDY(i, j, mz))
+ enddo
+ ! end do
+ else
+ ! +--Above the Surface Layer
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ ! do j=1,my
+ do i = 1, mx
+ gpmiDY(i, j, mzz - k) = gpmiDY(i, j, mzz + 1 - k) &
+ + (WKxy1(i, j) - WKxy2(i, j)) * pktaDY(i, j, mzz - k) &
+ * (1.0 + virDY(i, j, mzz - k))
+ enddo
+ ! end do
+ endif
+ ! do j=1,my
+ do i = 1, mx
+ WKxy1(i, j) = WKxy2(i, j)
+ enddo
+ ! end do
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Update of u and v at the Lateral Boundaries
+ ! + ===========================================
+
+ !$OMP PARALLEL do private(i,j,k,c1a,c1b,dudt_t,c1a_t,ddux,ddvx)
+ do k = 1, mz
+ do j = 1, my
+ ubefDY(1, j, k) = uairDY(1, j, k)
+ ubefDY(mx, j, k) = uairDY(mx, j, k)
+ vbefDY(1, j, k) = vairDY(1, j, k)
+ vbefDY(mx, j, k) = vairDY(mx, j, k)
+ enddo
+ ! end do
+ if(mmy > 1) then
+ ! do k=1,mz
+ do i = 1, mx
+ ubefDY(i, 1, k) = uairDY(i, 1, k)
+ ubefDY(i, my, k) = uairDY(i, my, k)
+ vbefDY(i, 1, k) = vairDY(i, 1, k)
+ vbefDY(i, my, k) = vairDY(i, my, k)
+ enddo
+ ! end do
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Mesoscale Geopotential Gradient
+ ! + ===============================
+
+ ! do k=1,mz
+
+ ! +--For Hydrostatic Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if (k==mz) then
+ do j = 1, my
+ do i = 1, mx
+ WKxyz7(i, j, k) = WKxy4(i, j)
+ WKxyz1(i, j, k) = gplvDY(i, j, mzz)
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ WKxyz7(i, j, k) = WKxyz4(i, j, k + 1)
+ WKxyz1(i, j, k) = gpmiDY(i, j, k + 1)
+ enddo
+ enddo
+ end if
+
+ do j = 1, my
+ do i = 1, mx
+ ! WKxyz8 = P**(R/Cp)(k-1/2) - P**(R/Cp)(k+1/2)
+ WKxyz8(i, j, k) = WKxyz4(i, j, k) - WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--For Hydrostatic Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! do j = jp11, my1
+ ! do i = ip11, mx1 ! i = 1, mx
+ do j = 1, my
+ do i = 1, mx
+ ! WKxyz2 = ( P**(R/Cp)(k-1/2) * gpmiDY(k + 1/2) - P**(R/Cp)(k+1/2) * gpmiDY(i, j, k-1/2) ) / ( P**(R/Cp)(k-1/2) - P**(R/Cp)(k+1/2) )
+ WKxyz2(i, j, k) = (WKxyz4(i, j, k) * WKxyz1(i, j, k) - WKxyz7(i, j, k) * gpmiDY(i, j, k)) / WKxyz8(i, j, k)
+ ! WKxyz3 = ( gpmiDY(i, j, k-1/2) - gpmiDY(k + 1/2) ) / ( P**(R/Cp)(k-1/2) - P**(R/Cp)(k+1/2) ) (later : * P**(R/Cp)(k))
+ WKxyz3(i, j, k) = (gpmiDY(i, j, k) - WKxyz1(i, j, k)) / WKxyz8(i, j, k)
+ ! P2 = P**(R/Cp)(k-1/2) | P1 = P**(R/Cp)(k+1/2) | Phi2 = gpmiDY(i, j, k-1/2) | Phi2 = gpmiDY(i, j, k+1/2)
+ ! Phi = (Phi1 + Phi2) / 2.
+ ! (P2 - P1) * (Phi1 + Phi2) = P2 * Phi1 + P2 * Phi2 - P1 * Phi1 - P1 * Phi2
+ ! = (P2 * Ph1 - P1 * Phi2) + (P2 * Phi2 - P1 * Phi1)
+ ! = (P2 * Ph1 - P1 * Phi2) + P * (Phi2 - Phi1)
+ ! = WKxyz2 * (P2 - P1) + P * WKxyz3 * (P2 - P1)
+ ! = (P2 - P1) * 2 * Phi
+ enddo
+ enddo
+
+ ! +--Gradient following x
+ ! + --------------------
+ if(norder == 2) then
+ do i = 1, mx
+ do j = jp11, my1
+ WKxyz5(i, j, k) = (WKxyz2(ip1(i), j, k) - WKxyz2(im1(i), j, k)) * dxinv3(i, j)
+ WKxyz6(i, j, k) = (WKxyz3(ip1(i), j, k) - WKxyz3(im1(i), j, k)) * dxinv3(i, j)
+ enddo
+ enddo
+ else
+ do i = 1, mx
+ do j = jp11, my1
+ WKxyz5(i, j, k) = &
+ fac43 * (WKxyz2(ip1(i), j, k) - WKxyz2(im1(i), j, k) &
+ - 0.125 * (WKxyz2(ip2(i), j, k) - WKxyz2(im2(i), j, k))) * dxinv3(i, j)
+ WKxyz6(i, j, k) = &
+ fac43 * (WKxyz3(ip1(i), j, k) - WKxyz3(im1(i), j, k) &
+ - 0.125 * (WKxyz3(ip2(i), j, k) - WKxyz3(im2(i), j, k))) * dxinv3(i, j)
+ enddo
+ enddo
+ endif
+
+ ! +--Contribution to u Wind Speed Component
+ ! + --------------------------------------
+ if (itFast==1) then
+ ! +- First Step
+ ! + ~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz1(i, j, k)
+
+ c1b = dtfast * c1a
+ ubefDY(i, j, k) = uairDY(i, j, k) + c1b
+ uairDY(i, j, k) = uairDY(i, j, k) + c1b + c1b
+ if(track_dgz) then
+ ! cCA value without gradient time scheme
+ ! cCA in standard configuration, ntFast = 1 => itFast = 1..2
+ ! values added to ubefDY = uairDY(n-1)
+ ! compute new values
+ c1a_t(i_dgzpgf) = - WKxyz5(i, j, k) - pkDY(i, j, k) * WKxyz6(i, j, k)
+ c1a_t(i_dgzadv) = WTxyz1(i, j, k)
+ ! u_tm1 = uairDY + dtfast * dudt
+ ! u_t = uairDY + 2 * dtfast * dudt
+ ! save previous values
+ do itw = 1, ntrackdgz
+ delta_u_dgz(i, j, k, itw) = delta_u_dgz(i, j, k, itw) + 2. * dtfast * c1a_t(itw)
+ dudt_tm1(i, j, k, itw) = c1a_t(itw) * 0.5
+ c1a_tm2(i, j, k, itw) = c1a_t(itw)
+ c1a_tm1(i, j, k, itw) = c1a_t(itw)
+ end do
+ end if
+ dg1xDY(i, j, k) = c1a ! dudt_tm2
+ dgzxDY(i, j, k) = c1a ! dudt_tm1
+ enddo
+ enddo
+ else
+ ! +- Next Step
+ ! + ~~~~~~~~~~
+ if(itFast <= ntFast) then
+ if(brocam) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz1(i, j, k)
+
+ ddux = ubefDY(i, j, k)
+ ubefDY(i, j, k) = uairDY(i, j, k)
+ uairDY(i, j, k) = ddux + 2.0 * dtfast &
+ * (bcb * dgzxDY(i, j, k) &
+ + bca * (c1a + dg1xDY(i, j, k)))
+ ! +... U (n+1) = U(n-1) + 2 Dt (Du/Dt)
+ if(track_dgz) then
+ ! cCA value without gradient time scheme
+ ! cCA in standard configuration, ntFast = 1 => itFast = 1..2
+ ! compute new values
+ c1a_t(i_dgzpgf) = - WKxyz5(i, j, k) - pkDY(i, j, k) * WKxyz6(i, j, k)
+ c1a_t(i_dgzadv) = WTxyz1(i, j, k)
+ do itw = 1, ntrackdgz
+ dudt_t = bcb * c1a_tm1(i, j, k, itw) + bca * (c1a_t(itw) + c1a_tm2(i, j, k, itw))
+ ! u_tm1 = uairDY - 2 * dtfast * dudt_tm1
+ ! uairDY = u_tm1 + 2 * dtfast * dudt_t
+ ! uairDY = uairDY + 2 * dtfast * (dudt_t - dudt_tm1)
+ delta_u_dgz(i, j, k, itw) = delta_u_dgz(i, j, k, itw) + &
+ 2. * dtfast * (dudt_t - dudt_tm1(i, j, k, itw))
+ ! save previous values
+ dudt_tm1(i, j, k, itw) = dudt_t
+ c1a_tm2(i, j, k, itw) = c1a_tm1(i, j, k, itw)
+ c1a_tm1(i, j, k, itw) = c1a_t(itw)
+ end do
+ end if
+#if(rt)
+ ! +- Robert Time Filter
+ ! + ~~~~~~~~~~~~~~~~~~
+ ubefDY(i, j, k) = ubefDY(i, j, k) &
+ + Robert * (0.5 * (uairDY(i, j, k) + ddux) - ubefDY(i, j, k))
+#endif
+ dg1xDY(i, j, k) = dgzxDY(i, j, k) ! dudt_tm2 = dudt_tm1
+ dgzxDY(i, j, k) = c1a ! dudt_tm1 = dudt_t
+ enddo
+ enddo
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz1(i, j, k)
+
+ ddux = ubefDY(i, j, k)
+ ubefDY(i, j, k) = uairDY(i, j, k)
+ uairDY(i, j, k) = ddux + 2.0 * dtfast * c1a
+ ! +... U (n+1) = U(n-1) + 2 Dt (Du/Dt)
+
+ enddo
+ enddo
+ endif
+ else
+ ! +- Last Step
+ ! + ~~~~~~~~~~
+ if(brocam) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz1(i, j, k)
+
+ ddux = ubefDY(i, j, k)
+ ubefDY(i, j, k) = uairDY(i, j, k)
+ uairDY(i, j, k) = ddux + dtfast &
+ * (bcb * dgzxDY(i, j, k) &
+ + bca * (c1a + dg1xDY(i, j, k)))
+ ! +... U (n+1) = U(n) + Dt (Du/Dt)'
+ ! + Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+ if(track_dgz) then
+ ! cCA value without gradient time scheme
+ ! cCA in standard configuration, ntFast = 1 => itFast = 1..2
+ ! compute new values
+ c1a_t(i_dgzpgf) = - WKxyz5(i, j, k) - pkDY(i, j, k) * WKxyz6(i, j, k)
+ c1a_t(i_dgzadv) = WTxyz1(i, j, k)
+ do itw = 1, ntrackdgz
+ dudt_t = bcb * c1a_tm1(i, j, k, itw) + bca * (c1a_t(itw) + c1a_tm2(i, j, k, itw))
+ ! u_tm1 = uairDY - 2 * dtfast * dudt_tm1
+ ! uairDY = u_tm1 + dtfast * dudt_t
+ ! uairDY = uairDY + dtfast * (dudt_t - 2 * dudt_tm1)
+ delta_u_dgz(i, j, k, itw) = delta_u_dgz(i, j, k, itw) + &
+ dtfast * (dudt_t - 2 * dudt_tm1(i, j, k, itw))
+ end do
+ end if
+ dg1xDY(i, j, k) = dgzxDY(i, j, k)
+ dgzxDY(i, j, k) = c1a
+ enddo
+ enddo
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz1(i, j, k)
+
+ ddux = ubefDY(i, j, k)
+ ubefDY(i, j, k) = uairDY(i, j, k)
+ uairDY(i, j, k) = ddux + dtfast * c1a
+ ! +... U (n+1) = U(n) + Dt (Du/Dt)'
+ ! + Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+
+ enddo
+ enddo
+ endif
+ endif
+ endif
+
+ ! +- Gradient following y
+ ! + --------------------
+
+ if(mmy > 1) then
+ ! do j = 1, my
+ ! WKxyz2(1, j, k) = 0.
+ ! WKxyz2(mx, j, k) = 0.
+ ! WKxyz3(1, j, k) = 0.
+ ! WKxyz3(mx, j, k) = 0.
+ ! enddo
+ ! do i = ip11, mx1
+ ! WKxyz2(i, 1, k) = (WKxyz4(i, 1, k) * WKxyz1(i, 1, k) - WKxyz7(i, 1, k) * gpmiDY(i, 1, k)) / WKxyz8(i, 1, k)
+ ! WKxyz3(i, 1, k) = (gpmiDY(i, 1, k) - WKxyz1(i, 1, k)) / WKxyz8(i, 1, k)
+ ! WKxyz2(i, my, k) = (WKxyz4(i, my, k) * WKxyz1(i, my, k) - WKxyz7(i, my, k) * gpmiDY(i, my, k)) / WKxyz8(i, my, k)
+ ! WKxyz3(i, my, k) = (gpmiDY(i, my, k) - WKxyz1(i, my, k)) / WKxyz8(i, my, k)
+ ! end do
+ ! do j = jp11, my1
+ ! do i = 1, mx
+
+ ! +--For Hydrostatic Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! do i = ip11, mx1
+ ! do j = 1, my
+ ! WKxyz2(i, j, k) = (WKxyz4(i, j, k) * WKxyz1(i, j, k) &
+ ! - WKxyz7(i, j, k) * gpmiDY(i, j, k)) / WKxyz8(i, j, k)
+ ! WKxyz3(i, j, k) = (gpmiDY(i, j, k) - WKxyz1(i, j, k)) / WKxyz8(i, j, k)
+ ! enddo
+ ! enddo
+
+ if(norder == 2) then
+ do j = 1, my
+ do i = ip11, mx1
+ WKxyz5(i, j, k) = (WKxyz2(i, jp1(j), k) - WKxyz2(i, jm1(j), k)) * dyinv3(i, j)
+ WKxyz6(i, j, k) = (WKxyz3(i, jp1(j), k) - WKxyz3(i, jm1(j), k)) * dyinv3(i, j)
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = ip11, mx1
+ WKxyz5(i, j, k) = fac43 * (WKxyz2(i, jp1(j), k) - WKxyz2(i, jm1(j), k)&
+ - 0.125 * (WKxyz2(i, jp2(j), k) - WKxyz2(i, jm2(j), k))) * dyinv3(i, j)
+ WKxyz6(i, j, k) = fac43 * (WKxyz3(i, jp1(j), k) - WKxyz3(i, jm1(j), k)&
+ - 0.125 * (WKxyz3(i, jp2(j), k) - WKxyz3(i, jm2(j), k))) * dyinv3(i, j)
+ enddo
+ enddo
+ endif
+
+ ! +--Contribution to v Wind Speed Component
+ ! + --------------------------------------
+ if (itFast==1) then
+ ! +- First Step
+ ! + ~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz2(i, j, k)
+
+ c1b = dtfast * c1a
+ vbefDY(i, j, k) = vairDY(i, j, k) + c1b
+ vairDY(i, j, k) = vairDY(i, j, k) + c1b + c1b
+ if(track_dgz) then
+ ! cCA value without gradient time scheme
+ ! cCA in standard configuration, ntFast = 1 => itFast = 1..2
+ ! values added to ubefDY = uairDY(n-1)
+ ! compute new values
+ c1a_t(i_dgzpgf) = - WKxyz5(i, j, k) - pkDY(i, j, k) * WKxyz6(i, j, k)
+ c1a_t(i_dgzadv) = WTxyz2(i, j, k)
+ do itw = 1, ntrackdgz
+ ! u_tm1 = uairDY + dtfast * dudt
+ ! u_t = uairDY + 2 * dtfast * dudt
+ delta_v_dgz(i, j, k, itw) = delta_v_dgz(i, j, k, itw) + 2. * dtfast * c1a_t(itw)
+ ! save previous values
+ dudt_tm1(i, j, k, itw) = c1a_t(itw) * 0.5
+ c1a_tm2(i, j, k, itw) = c1a_t(itw)
+ c1a_tm1(i, j, k, itw) = c1a_t(itw)
+ end do
+ end if
+
+ dg1yDY(i, j, k) = c1a
+ dgzyDY(i, j, k) = c1a
+ enddo
+ enddo
+ else
+ ! +- Next Step
+ ! + ~~~~~~~~~~
+ if(itFast <= ntFast) then
+ if(brocam) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz2(i, j, k)
+
+ ddvx = vbefDY(i, j, k)
+ vbefDY(i, j, k) = vairDY(i, j, k)
+ vairDY(i, j, k) = ddvx + 2.0 * dtfast &
+ * (bcb * dgzyDY(i, j, k) &
+ + bca * (c1a + dg1yDY(i, j, k)))
+ ! + V (n+1) = V(n-1) + 2 Dt (Dv/Dt)
+ if(track_dgz) then
+ ! cCA value without gradient time scheme
+ ! cCA in standard configuration, ntFast = 1 => itFast = 1..2
+ ! compute new values
+ c1a_t(i_dgzpgf) = - WKxyz5(i, j, k) - pkDY(i, j, k) * WKxyz6(i, j, k)
+ c1a_t(i_dgzadv) = WTxyz2(i, j, k)
+ do itw = 1, ntrackdgz
+ dudt_t = bcb * c1a_tm1(i, j, k, itw) + bca * (c1a_t(itw) + c1a_tm2(i, j, k, itw))
+ ! u_tm1 = uairDY - 2 * dtfast * dudt_tm1
+ ! uairDY = u_tm1 + 2 * dtfast * dudt_t
+ ! uairDY = uairDY + 2 * dtfast * (dudt_t - dudt_tm1)
+ delta_v_dgz(i, j, k, itw) = delta_v_dgz(i, j, k, itw) + &
+ 2. * dtfast * (dudt_t - dudt_tm1(i, j, k, itw))
+ ! save previous values
+ dudt_tm1(i, j, k, itw) = dudt_t
+ c1a_tm2(i, j, k, itw) = c1a_tm1(i, j, k, itw)
+ c1a_tm1(i, j, k, itw) = c1a_t(itw)
+ end do
+ end if
+#if(rt)
+ ! +- Robert Time Filter
+ ! + ~~~~~~~~~~~~~~~~~~
+ vbefDY(i, j, k) = vbefDY(i, j, k) &
+ + Robert * (0.5 * (vairDY(i, j, k) + ddvx) - vbefDY(i, j, k))
+#endif
+ dg1yDY(i, j, k) = dgzyDY(i, j, k)
+ dgzyDY(i, j, k) = c1a
+ enddo
+ enddo
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz2(i, j, k)
+
+ ddvx = vbefDY(i, j, k)
+ vbefDY(i, j, k) = vairDY(i, j, k)
+ vairDY(i, j, k) = ddvx + 2.0 * dtfast * c1a
+ ! + V (n+1) = V(n-1) + 2 Dt (Dv/Dt)
+
+ enddo
+ enddo
+ endif
+ else
+ ! +- Last Step
+ ! + ~~~~~~~~~~
+ if(brocam) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz2(i, j, k)
+
+ ddvx = vbefDY(i, j, k)
+ vbefDY(i, j, k) = vairDY(i, j, k)
+ vairDY(i, j, k) = ddvx + dtfast &
+ * (bcb * dgzyDY(i, j, k) &
+ + bca * (c1a + dg1yDY(i, j, k)))
+ ! +... V (n+1) = V(n) + Dt (Dv/Dt)'
+ ! + Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+
+ if(track_dgz) then
+ ! cCA value without gradient time scheme
+ ! cCA in standard configuration, ntFast = 1 => itFast = 1..2
+ ! compute new values
+ c1a_t(i_dgzpgf) = - WKxyz5(i, j, k) - pkDY(i, j, k) * WKxyz6(i, j, k)
+ c1a_t(i_dgzadv) = WTxyz2(i, j, k)
+ do itw = 1, ntrackdgz
+ dudt_t = bcb * c1a_tm1(i, j, k, itw) + bca * (c1a_t(itw) + c1a_tm2(i, j, k, itw))
+ ! u_tm1 = uairDY - 2 * dtfast * dudt_tm1
+ ! uairDY = u_tm1 + dtfast * dudt_t
+ ! uairDY = uairDY + dtfast * (dudt_t - 2 * dudt_tm1)
+ delta_v_dgz(i, j, k, itw) = delta_v_dgz(i, j, k, itw) + &
+ dtfast * (dudt_t - 2 * dudt_tm1(i, j, k, itw))
+ end do
+ end if
+ dg1yDY(i, j, k) = dgzyDY(i, j, k)
+ dgzyDY(i, j, k) = c1a
+ enddo
+ enddo
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ c1a = -(WKxyz5(i, j, k) + pkDY(i, j, k) * WKxyz6(i, j, k)) &
+ + WTxyz2(i, j, k)
+
+ ddvx = vbefDY(i, j, k)
+ vbefDY(i, j, k) = vairDY(i, j, k)
+ vairDY(i, j, k) = ddvx + dtfast * c1a
+ ! +... V (n+1) = V(n) + Dt (Dv/Dt)'
+ ! + Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+
+ enddo
+ enddo
+ endif
+ endif
+ endif
+ endif
+
+ ! +--Rayleigh Friction (Ref. ARPS 4.0 User's Guide, para 6.4.3 p.152)
+ ! + =================
+ if(k <= mzabso) then
+ do j = 1, my
+ do i = 1, mx
+ uairDY(i, j, k) = (uairDY(i, j, k) + Ray_UB(k) * dtFast * uairUB(i, j, k)) &
+ / (1.0 + Ray_UB(k) * dtFast)
+ vairDY(i, j, k) = (vairDY(i, j, k) + Ray_UB(k) * dtFast * vairUB(i, j, k)) &
+ / (1.0 + Ray_UB(k) * dtFast)
+ enddo
+ enddo
+ endif
+ enddo
+ !$OMP END PARALLEL DO
+ return
+end
diff --git a/MAR/code_mar/dyndps.f90 b/MAR/code_mar/dyndps.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fb03d07285ce027854edcbec5a8f7a65987b260b
--- /dev/null
+++ b/MAR/code_mar/dyndps.f90
@@ -0,0 +1,1264 @@
+#include "MAR_pp.def"
+subroutine DYNdps_mp(norder)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FAST 15-04-2021 MAR |
+ ! | subroutine DYNdps solves the Mass Conservation Equation |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT/ (via common block) |
+ ! | ^^^^^ iterun : long time step counter |
+ ! | itFast : short time step counter |
+ ! | norder : numerical scheme: order of precision |
+ ! | |
+ ! | INPUT/ (via common block) |
+ ! | OUTPUT pstDYn(mx,my) : Pressure Depth p*(t) (kPa) |
+ ! | ^^^^^^ pstDY(mx,my) : Pressure Depth p*(t-dt) |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ uairDY(mx,my,mz): x-Wind Speed (m/s) |
+ ! | vairDY(mx,my,mz): y-Wind Speed (m/s) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ psigDY: p* X Vertical Wind Speed; Sigma Syst.(i.e. p* Ds/Dt) |
+ ! | psigDY Computed ON the Sigma Levels (unstaggered) |
+ ! | IN Layers (staggered) |
+ ! | |
+ ! | METHOD: Implicit Time Scheme (pImplc Switch is .true. ) |
+ ! | ^^^^^^ 2th order accurate Time Scheme (semi-implicit) .and. |
+ ! | 2th order accurate Space Scheme on Arakawa A grid |
+ ! | |
+ ! | Explicit Time Scheme (pImplc Switch is .false.) |
+ ! | Centered Scheme (center Switch is .true. ) |
+ ! | 2th order accurate Time Scheme (leapfrog backw.) .and. |
+ ! | norder.EQ.2 (2th order accurate Space Scheme on Arakawa A grid .OR. |
+ ! | norder.NE.2 4th order accurate Space Scheme on Arakawa A grid) |
+ ! | .OR. |
+ ! | Non-Centered Scheme (center Switch is .false.) |
+ ! | 0th order accurate Space Scheme (Bott) (norder=0) .OR. |
+ ! | 4th order accurate Space Scheme (Bott) (norder=4) |
+ ! | |
+ ! | Robert Time Filter may be used to remove computational mode |
+ ! | |
+ ! | REFER.: Use of A grid: Purser and Leslie, MWR 116, 2069--2080, 1988 |
+ ! | ^^^^^^ Time Scheme : Lin and Rood MWR 124, 2046--2070, 1996 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_wk
+#if(ON)
+ use mar_te
+#endif
+
+ implicit none
+
+ integer i, j, k, m
+ integer norder
+
+ logical pImplc, locorr
+
+ integer mxx, myy
+ parameter(mxx=mx + 1, myy=my + 1)
+ real vecx(0:mxx), flux(0:mxx)
+ real aa0x(0:mxx), aa1x(0:mxx), aa2x(0:mxx)
+ real aa3x(0:mxx), aa4x(0:mxx)
+ real cnpx(0:mxx), cnmx(0:mxx)
+ real sipx(0:mxx), simx(0:mxx), sidx(0:mxx)
+ real vecy(0:myy), fluy(0:myy)
+ real aa0y(0:myy), aa1y(0:myy), aa2y(0:myy)
+ real aa3y(0:myy), aa4y(0:myy)
+ real cnpy(0:myy), cnmy(0:myy)
+ real sipy(0:myy), simy(0:myy), sidy(0:myy)
+
+ integer it_pst, nt_pst, idir_x, jdir_y
+ integer i1_dps, i2_dps, j1_dps, j2_dps, k1_dps, k2_dps
+ real alphpp, betapp, Fp__pp, Fpa_pp, Fpb_pp, facovr
+ real CorArg, CorrNH, SRes_0, SRes_1, SRes10, pst_n1
+ real dtcorr, dtxfas, dtyfas, uuface, vvface
+
+ integer numdps, ntpsig
+ common / DYNdps_int / numdps, ntpsig
+
+ real psigad(mx, my, mz)
+ common / DYNdps_rea / psigad
+
+ ! +--DATA
+ ! + ====
+ ! +... pImplc=.true. ==> Implicit Scheme is used to damp Lamb Waves
+ data pImplc/.false./
+
+ numdps = numdps + 1
+
+ ! +--Save Mass at the Lateral Boundaries
+ ! + ===================================
+ do j = 1, my
+ do i = 1, mx
+ ! + p*(n-1)
+ WTxy1(i, j) = pstDY(i, j)
+ ! + p*(n)
+ WTxy2(i, j) = pstDYn(i, j)
+ enddo
+ enddo
+
+ do j = 1, my
+ pstDY(1, j) = pstDYn(1, j)
+ pstDY(mx, j) = pstDYn(mx, j)
+ enddo
+
+ if(mmy > 1) then
+ do i = 1, mx
+ pstDY(i, 1) = pstDYn(i, 1)
+ pstDY(i, my) = pstDYn(i, my)
+ enddo
+ endif
+
+ if(pImplc) then
+ ! ++++++++++++++++++++++++++++
+ ! +--IMPLICIT SCHEME (BEGIN) +
+ ! ++++++++++++++++++++++++++++
+ if(it_Mix == 1 .and. itFast == 1) then
+ ! +--Horizontal Wind Speed: Average along the Vertical
+ ! + -------------------------------------------------
+ do j = 1, my
+ do i = 1, mx
+ WTxy3(i, j) = 0.0
+ WTxy4(i, j) = 0.0
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxy3(i, j) = WTxy3(i, j) + uairDY(i, j, k) * dsigm1(k)
+ WTxy4(i, j) = WTxy4(i, j) + vairDY(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Tridiagonal Matrix Coefficients
+ ! + -------------------------------
+ betapp = 0.6
+ alphpp = 1.0 - betapp
+ Fp__pp = dt / dx
+ Fpa_pp = Fp__pp * alphpp
+ Fpb_pp = Fp__pp * betapp
+ do i = ip11, mx1
+ do j = jp11, my1
+ WTxyz1(i, j, 1) = Fpb_pp * WTxy3(ip1(i), j) ! k=1: 3-Diag Matrix, x-Dir
+ WTxyz3(i, j, 1) = -Fpb_pp * WTxy3(im1(i), j) ! k=1: 3-Diag Matrix, x-Dir
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz1(i, j, 2) = Fpb_pp * WTxy4(i, jp1(j)) ! k=2: 3-Diag Matrix, y-Dir
+ WTxyz3(i, j, 2) = -Fpb_pp * WTxy4(i, jm1(j)) ! k=2: 3-Diag Matrix, y-Dir
+ enddo
+ enddo
+
+ ! +--Overrelaxation Starting Block
+ ! + -----------------------------
+
+ ! +--Independant Term: constant contribution ! x-Dir
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = ip11, mx1
+ do j = jp11, my1
+ WTxyz8(i, j, 1) = pstDY(i, j) &
+ - Fpa_pp * WTxy3(ip1(i), j) * pstDY(ip1(i), j) &
+ + Fpa_pp * WTxy3(im1(i), j) * pstDY(im1(i), j)
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz8(i, j, 1) = WTxyz8(i, j, 1) &
+ - Fpa_pp * WTxy4(i, jp1(j)) * pstDY(i, jp1(j)) &
+ + Fpa_pp * WTxy4(i, jm1(j)) * pstDY(i, jm1(j))
+ enddo
+ enddo
+
+ ! +--Dirichlet Condition x-LBC ! x-Dir
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~
+ i = mx1
+ do j = jp11, my1
+ WTxyz8(i, j, 1) = WTxyz8(i, j, 1) - Fpb_pp * WTxy3(ip1(i), j) * pstDY(ip1(i), j)
+ WTxyz1(i, j, 1) = 0.0
+#if(WR)
+ write(6, *) ip1(i), ' ', pstDY(ip1(i), j)
+#endif
+ enddo
+
+ i = ip11
+ do j = jp11, my1
+ WTxyz8(i, j, 1) = WTxyz8(i, j, 1) &
+ + Fpb_pp * WTxy3(im1(i), j) * pstDY(im1(i), j)
+ WTxyz3(i, j, 1) = 0.0
+#if(WR)
+ write(6, *) im1(i), ' ', pstDY(im1(i), j)
+#endif
+ enddo
+
+ ! +--Dirichlet Condition y-LBC
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(mmy > 1) then
+ j = my1
+ do i = ip11, mx1
+ WTxyz8(i, j, 1) = WTxyz8(i, j, 1) &
+ - Fpb_pp * WTxy3(i, jp1(j)) * pstDY(i, jp1(j))
+ WTxyz1(i, j, 2) = 0.0
+#if(WR)
+ write(6, *) jp1(j), ' ', pstDY(i, jp1(j))
+#endif
+ enddo
+ ! +
+ j = jp11
+ do i = ip11, mx1
+ WTxyz8(i, j, 1) = WTxyz8(i, j, 1) &
+ + Fpb_pp * WTxy3(i, jm1(j)) * pstDY(i, jm1(j))
+ WTxyz3(i, j, 2) = 0.0
+#if(WR)
+ write(6, *) jm1(j), ' ', pstDY(i, jm1(j))
+#endif
+ enddo
+ endif
+
+ ! +--First Estimate
+ ! + ~~~~~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz7(i, j, 1) = pstDY(i, j) ! Previous Estimate
+ WTxyz7(i, j, 2) = 0.0 ! Half-Iteration Estimate
+ WTxyz7(i, j, 3) = pstDY(i, j) ! Next to update Estimate
+ enddo
+ enddo
+
+ ! +--Recurrence
+ ! + ~~~~~~~~~~
+ facovr = 1.1
+ nt_pst = 4
+ it_pst = 0
+ SRes_1 = 0.0
+1000 continue
+ it_pst = it_pst + 1
+
+ ! +--Resolution along the x-Direction
+ ! + --------------------------------
+
+ ! +--Tridiagonal Matrix Coefficients
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz1(i, j, 3) = WTxyz1(i, j, 1) ! Index 1 ==> x-Dir
+ WTxyz2(i, j, 3) = 1.0d+0 !
+ WTxyz3(i, j, 3) = WTxyz3(i, j, 1) !
+ enddo
+ enddo
+
+ ! +--Independant Term
+ ! + ~~~~~~~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ ! Index 1 ==> ALL-Dir
+ WTxyz4(i, j, 3) = WTxyz8(i, j, 1) &
+ - WTxyz1(i, j, 2) * WTxyz7(i, jp1(j), 1) &
+ - WTxyz3(i, j, 2) * WTxyz7(i, jm1(j), 1)
+ enddo
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion ! OUTPUT is WTxyz7(i,j,3)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ i1_dps = ip11
+ i2_dps = mx1
+ j1_dps = jp11
+ j2_dps = my1
+ k1_dps = 3
+ k2_dps = 3
+
+ ! + ********
+ call MARgau_x(i1_dps, i2_dps, j1_dps, j2_dps, k1_dps, k2_dps)
+ ! + ********
+
+ ! +--Resolution along the y-Direction
+ ! + --------------------------------
+
+ if(mmy > 1) then
+ ! +--Tridiagonal Matrix Coefficients ! Index 2 ==> y-Dir
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz1(i, j, 3) = WTxyz1(i, j, 2)
+ WTxyz2(i, j, 3) = 1.
+ WTxyz3(i, j, 3) = WTxyz3(i, j, 2)
+ ! Half-Iteration Estimate
+ WTxyz7(i, j, 2) = WTxyz7(i, j, 3)
+ enddo
+ enddo
+
+ ! +--Independant Term ! y-Dir
+ ! + ~~~~~~~~~~~~~~~~
+ do i = ip11, mx1
+ do j = jp11, my1
+ ! Index 1 ==> ALL-Dir
+ WTxyz4(i, j, 3) = WTxyz8(i, j, 1) &
+ - WTxyz1(i, j, 1) * WTxyz7(ip1(i), j, 2) &
+ - WTxyz3(i, j, 1) * WTxyz7(im1(i), j, 2)
+ enddo
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion ! OUTPUT is WTxyz7(i,j,3)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ i1_dps = ip11
+ i2_dps = mx1
+ j1_dps = jp11
+ j2_dps = my1
+ k1_dps = 3
+ k2_dps = 3
+
+ ! + ********
+ call MARgau_y(i1_dps, i2_dps, j1_dps, j2_dps, k1_dps, k2_dps)
+ ! + ********
+
+ endif
+
+ ! +--Residual is obtained by substracting next from former estimated Equation
+ ! + ------------------------------------------------------------------------
+
+ do i = ip11, mx1
+ do j = jp11, my1
+ WTxyz6(i, j, 1) = WTxyz1(i, j, 1) * WTxyz7(ip1(i), j, 3) &
+ + WTxyz3(i, j, 1) * WTxyz7(im1(i), j, 3)
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz6(i, j, 1) = WTxyz6(i, j, 1) &
+ + WTxyz1(i, j, 2) * WTxyz7(i, jp1(j), 3) &
+ + WTxyz3(i, j, 2) * WTxyz7(i, jm1(j), 3) &
+ + WTxyz7(i, j, 3) &
+ - WTxyz8(i, j, 1)
+ enddo
+ enddo
+
+ SRes_1 = 0.0
+ do j = jp11, my1
+ do i = ip11, mx1
+ SRes_1 = SRes_1 + abs(WTxyz6(i, j, 1))
+ enddo
+ enddo
+
+ if(it_pst > 1) then
+ SRes10 = SRes_1 / SRes_0
+ else
+ SRes_0 = SRes_1
+ SRes10 = 1.0
+ endif
+
+ ! +--New Estimate
+ ! + ------------
+
+ if(SRes10 > 0.1 .and. it_pst < nt_pst &
+ .and. mmy > 1) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ WTxyz7(i, j, 1) = WTxyz7(i, j, 3) &
+ - facovr * WTxyz6(i, j, 1) / WTxyz2(i, j, 1)
+ WTxyz7(i, j, 3) = WTxyz7(i, j, 1)
+ enddo
+ enddo
+ endif
+ ! +
+#if(WR)
+ write(6, 1001) iterun, it_pst, SRes10
+1001 format(2i9, f21.15)
+#endif
+ ! +
+ if(SRes10 > 1.0d-1 .and. it_pst < nt_pst &
+ .and. mmy > 1) go to 1000
+
+ ! +--Final Estimate
+ ! + --------------
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ pstDY(i, j) = WTxyz7(i, j, 3)
+ pstDYn(i, j) = WTxyz7(i, j, 3)
+ enddo
+ enddo
+
+ ! +--Lateral Boundary Conditions
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do j = jp11, my1
+ pstDY(1, j) = WTxy1(1, j)
+ pstDY(mx, j) = WTxy1(mx, j)
+ pstDYn(1, j) = WTxy1(1, j)
+ pstDYn(mx, j) = WTxy1(mx, j)
+ enddo
+
+ if(mmy > 1) then
+ do i = ip11, mx1
+ pstDY(i, 1) = WTxy1(i, 1)
+ pstDY(i, my) = WTxy1(i, my)
+ pstDYn(i, 1) = WTxy1(i, 1)
+ pstDYn(i, my) = WTxy1(i, my)
+ enddo
+ endif
+
+ ! +--Contribution to Vertical Material Speed
+ ! + ---------------------------------------
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz3(i, j, k) = uairDY(i, j, k) * pstDYn(i, j)
+ WTxyz4(i, j, k) = vairDY(i, j, k) * pstDYn(i, j)
+ WTxyz8(i, j, k) = 0.
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WTxyz7(i, j, k) = (WTxyz3(im1(i), j, k) - WTxyz3(ip1(i), j, k) &
+ )
+ enddo
+ enddo
+
+ do i = 1, mx
+ do j = 1, my
+ WTxyz7(i, j, k) = (WTxyz7(i, j, k) &
+ + WTxyz4(i, jm1(j), k) - WTxyz4(i, jp1(j), k) &
+ ) * dxinv3(i, j)
+ enddo
+ enddo
+ !! Two previous Loops are the vectorized version of the following Loop
+ !! do j=1,my
+ !! do i=1,mx
+ !! WTxyz7(i,j,k)= -dxinv3(i, j)
+ !! . *(WTxyz3(ip1(i),j,k)-WTxyz3(im1(i),j,k)
+ !! . +WTxyz4(i,jp1(j),k)-WTxyz4(i,jm1(j),k))
+ !! end do
+ !! end do
+ enddo
+ endif
+
+ ! ++++++++++++++++++++++++++
+ ! +--IMPLICIT SCHEME (END) +
+ ! ++++++++++++++++++++++++++
+ else
+ ! ++++++++++++++++++++++++++++
+ ! +--EXPLICIT SCHEME (BEGIN) +
+ ! ++++++++++++++++++++++++++++
+
+ ! +++++++++++++++++++++++
+ ! +--ERROR TEST (BEGIN) +
+ ! +++++++++++++++++++++++
+
+ if(norder < 0) then
+ stop '++++++++ Horizontal Advection badly conditioned / Order<0 ++'
+ else
+ if(center) then
+ ! ++++++++++++++++++++++++++++++++++
+ ! +...Is Centered Scheme (BEGIN) +
+ ! ++++++++++++++++++++++++++++++++++
+ !cCA usual setting go here
+ locorr = .false.
+ dtcorr = 1.000
+
+ ! +--Mass Divergence / First Direction
+ ! + ==================================
+
+ ! +--Mass Flux Update / x-Direction
+ ! + ------------------------------
+
+ !#if(SP)
+ ! cCA : SP not activated because weird if / else / end if
+ ! if (mod(numdps,2).eq.0.or.mmy.eq.1) then
+ !#endif
+
+ do j = 1, my
+ do i = 1, mx
+ WTxy3(i, j) = 0.0
+ enddo
+ enddo
+
+ !$OMP PARALLEL do private(i,j,k)
+ do k = 1, mz
+ ! +--Mass Flux Update / x-Direction
+ ! + ------------------------------
+ if(norder == 2) then
+ ! cCA usually norder==4
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz3(i, j, k) = uairDY(i, j, k) * pstDYn(i, j)
+#if(Z2)
+ WTxyz3(i, j, k) = WTxyz3(i, j, k) * clatGE(i, j)
+#endif
+ enddo
+ enddo
+ !c #vL end do
+
+ !c #vL do k=1,mz
+ do i = 1, mx
+ do j = 1, my
+ WTxyz7(i, j, k) = dxinv3(i, j) * ( &
+ WTxyz3(im1(i), j, k) - WTxyz3(ip1(i), j, k))
+#if(Z2)
+ WTxyz7(i, j, k) = WTxyz7(i, j, k) / clatGE(i, j)
+#endif
+ enddo
+ enddo
+ ! end do
+ else
+ ! cCA usual setting go here
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz3(i, j, k) = uairDY(i, j, k) * pstDYn(i, j)
+#if(Z2)
+ WTxyz3(i, j, k) = WTxyz3(i, j, k) * clatGE(i, j)
+#endif
+ enddo
+ enddo
+ !c #vL end do
+
+ !c #vL do k=1,mz
+ do i = 1, mx
+ do j = 1, my
+ WTxyz7(i, j, k) = dxinv3(i, j) * fac43 * ( &
+ 0.125 * (WTxyz3(ip2(i), j, k) - WTxyz3(im2(i), j, k)) &
+ - WTxyz3(ip1(i), j, k) + WTxyz3(im1(i), j, k))
+#if(Z2)
+ WTxyz7(i, j, k) = WTxyz7(i, j, k) / clatGE(i, j)
+#endif
+ enddo
+ enddo
+ ! end do
+ endif
+ ! +--Mass Flux Update / y-Direction
+ ! + ------------------------------
+ !#if(SP)
+ ! else
+ !#endif
+ if(norder == 2) then
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz4(i, j, k) = vairDY(i, j, k) * pstDYn(i, j)
+ enddo
+ enddo
+ !c #vL end do
+
+ !c #vL do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz8(i, j, k) = dyinv3(i, j) * ( &
+ WTxyz4(i, jm1(j), k) - WTxyz4(i, jp1(j), k))
+ enddo
+ enddo
+ !#if(SP)
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz7(i,j,k)= WTxyz8(i,j,k)
+ ! WTxyz8(i,j,k)= 0.0
+ ! end do
+ ! end do
+ !#endif
+ else
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz4(i, j, k) = vairDY(i, j, k) * pstDYn(i, j)
+ enddo
+ enddo
+ !c #vL end do
+
+ !c #vL do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz8(i, j, k) = dyinv3(i, j) * fac43 * ( &
+ 0.125 * (WTxyz4(i, jp2(j), k) - WTxyz4(i, jm2(j), k)) &
+ - WTxyz4(i, jp1(j), k) + WTxyz4(i, jm1(j), k))
+ enddo
+ enddo
+ !#if(SP)
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz7(i,j,k)= WTxyz8(i,j,k)
+ ! WTxyz8(i,j,k)= 0.0
+ ! end do
+ ! end do
+ !#endif
+
+ endif
+ !#if(SP)
+ ! end if
+ !#endif
+ enddo
+ !$OMP END PARALLEL DO
+
+ ! +--Pressure Depth Increment
+ ! + ------------------------
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxy3(i, j) = WTxy3(i, j) &
+ - (WTxyz7(i, j, k) + WTxyz8(i, j, k)) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Pressure Depth Update (Leapfrog-Backward)
+ ! + -----------------------------------------
+ if(itFast == 1) then
+ do j = 1, my
+ do i = 1, mx
+ pstDY(i, j) = WTxy2(i, j) - WTxy3(i, j) * dtfast
+ pstDYn(i, j) = WTxy2(i, j) - WTxy3(i, j) * 2.0 * dtfast
+ enddo
+ enddo
+ else
+ if(itFast <= ntFast) then
+ do j = 1, my
+ do i = 1, mx
+ pstDY(i, j) = WTxy2(i, j)
+ pstDYn(i, j) = WTxy1(i, j) - WTxy3(i, j) * 2.0 * dtfast
+#if(rt)
+ ! +--Robert Time Filter
+ ! + ~~~~~~~~~~~~~~~~~~
+ pstDY(i, j) = pstDY(i, j) + &
+ Robert * (0.5 * (pstDYn(i, j) + WTxy1(i, j)) - pstDY(i, j))
+#endif
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ pstDY(i, j) = WTxy2(i, j)
+ pstDYn(i, j) = WTxy1(i, j) - WTxy3(i, j) * dtfast
+ enddo
+ enddo
+ ! +*** Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+ endif
+ endif
+
+ !#if(SP)
+ ! +--Mass Divergence / Second Direction
+ ! + ==================================
+ ! if (mmy.gt.1) then
+ ! +--Mass Flux Update / x-Direction
+ ! + ------------------------------
+ ! if (mod(numdps,2).eq.1) then
+ ! if(norder .EQ.2) then
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz3(i,j,k)=uairDY(i,j,k) * pstDYn(i,j)
+ ! end do
+ ! end do
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz8(i,j,k)= dxinv3(i, j) * ( &
+ ! WTxyz3(im1(i),j,k)-WTxyz3(ip1(i),j,k) )
+ ! end do
+ ! end do
+ ! end do
+ ! else
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz3(i,j,k)=uairDY(i,j,k) * pstDYn(i,j)
+ ! end do
+ ! end do
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz8(i,j,k)= dxinv3(i, j) * fac43 * ( &
+ ! 0.125*(WTxyz3(ip2(i),j,k)-WTxyz3(im2(i),j,k)) &
+ ! -WTxyz3(ip1(i),j,k)+WTxyz3(im1(i),j,k) )
+ ! end do
+ ! end do
+ ! end do
+ ! end if
+ ! +--Mass Flux Update / y-Direction
+ ! + ------------------------------
+ ! else
+ ! if(norder .EQ.2) then
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz4(i,j,k)=vairDY(i,j,k) * pstDYn(i,j)
+ ! end do
+ ! end do
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz8(i,j,k)= dyinv3(i, j) * ( &
+ ! WTxyz4(i,jm1(j),k)-WTxyz4(i,jp1(j),k) )
+ ! end do
+ ! end do
+ ! end do
+ ! else
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz4(i,j,k)=vairDY(i,j,k) * pstDYn(i,j)
+ ! end do
+ ! end do
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxyz8(i,j,k)= dyinv3(i, j) * fac43 * ( &
+ ! 0.125*(WTxyz4(i,jp2(j),k)-WTxyz4(i,jm2(j),k)) &
+ ! -WTxyz4(i,jp1(j),k)+WTxyz4(i,jm1(j),k) )
+ ! end do
+ ! end do
+ ! end do
+ ! end if
+ ! end if
+ !#endif
+
+ ! +--Pressure Depth Increment
+ ! + ------------------------
+
+ do j = 1, my
+ do i = 1, mx
+ WTxy4(i, j) = 0.0
+ enddo
+ enddo
+ !#if(SP)
+ ! do k=1,mz
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxy4(i,j)=WTxy4(i,j)-WTxyz8(i,j,k)*dsigm1(k)
+ ! end do
+ ! end do
+ ! end do
+ ! do j=1,my
+ ! do i=1,mx
+ ! WTxy3(i,j)=WTxy3(i,j)+ WTxy4(i,j)
+ ! end do
+ ! end do
+ ! +--Pressure Depth Update (Leapfrog-Backward)
+ ! + --------------------------------------------
+ ! if (itFast.eq.1) then
+ ! do j=1,my
+ ! do i=1,mx
+ ! pstDY( i,j) = pstDY( i,j) - WTxy4(i,j) *dtfast
+ ! pstDYn(i,j) = pstDYn(i,j) - WTxy4(i,j) *2.0*dtfast
+ ! end do
+ ! end do
+ ! else
+ ! if (itFast.le.ntFast) then
+ ! do j=1,my
+ ! do i=1,mx
+ ! pstDY( i,j) = WTxy2( i,j)
+ ! pst_n1 = pstDYn(i,j)
+ ! pstDYn(i,j) = pstDYn(i,j) - WTxy4(i,j) *2.0*dtfast
+ !#endif
+#if(rt)
+ ! +--Robert Time Filter
+ ! + ~~~~~~~~~~~~~~~~~~
+ pstDY(i, j) = pstDY(i, j) + &
+ Robert * (0.5 * (pstDYn(i, j) + pst_n1) - pstDY(i, j))
+#endif
+ !#if(SP)
+ ! end do
+ ! end do
+ ! else
+ ! do j=1,my
+ ! do i=1,mx
+ ! pstDY( i,j) = WTxy2( i,j)
+ ! pstDYn(i,j) = pstDYn(i,j) - WTxy4(i,j) *dtfast
+ ! end do
+ ! end do
+ ! +*** Leapfrog-Backward (e.g. Haltiner and Williams, p.152)
+ ! end if
+ ! end if
+ ! end if
+ !#endif
+ norder = -1
+
+ ! ++++++++++++++++++++++++++++++++++
+ ! +...Is Centered Scheme (END) +
+ ! ++++++++++++++++++++++++++++++++++
+ else
+ ! ++++++++++++++++++++++++++++++++++
+ ! +...Non Centered Schemes (BEGIN) +
+ ! ++++++++++++++++++++++++++++++++++
+
+ locorr = .true.
+ dtcorr = dtfast
+
+ ! +--Vector for Positive Definite Variables
+ ! + ======================================
+
+ dtxfas = dtx / (ntFast + 1)
+ dtyfas = dty / (ntFast + 1)
+
+ do k = 1, mz
+
+ do j = 1, my
+ do i = 1, mx
+ WTxyz1(i, j, k) = -uairDY(i, j, k) * dtxfas
+ WTxyz2(i, j, k) = -vairDY(i, j, k) * dtyfas
+ uuface = 0.5 * (uairDY(i, j, k) + uairDY(ip1(i), j, k))
+ vvface = 0.5 * (vairDY(i, j, k) + vairDY(i, jp1(j), k))
+ WTxyz3(i, j, k) = 0.5 * (abs(uuface) + uuface) * dtxfas
+ WTxyz5(i, j, k) = 0.5 * (abs(uuface) - uuface) * dtxfas
+ WTxyz4(i, j, k) = 0.5 * (abs(vvface) + vvface) * dtyfas
+ WTxyz6(i, j, k) = 0.5 * (abs(vvface) - vvface) * dtyfas
+ enddo
+ enddo
+
+ enddo
+
+ ! +--Advection (Time Splitting)
+ ! + ==========================
+
+ ! +--Mass and Mass Flux
+ ! + ~~~~~~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ WTxy5(i, j) = pstDY(i, j)
+ WTxy1(i, j) = WTxy5(i, j)
+ WTxy2(i, j) = WTxy5(i, j)
+ WTxy3(i, j) = 0.
+ enddo
+ enddo
+
+ ! +--Conservative Scheme Order 0
+ ! + ===========================
+ ! +
+ if(norder == 0) then
+ norder = -1
+
+ ! +--Time Splitting
+ ! + --------------
+
+ ! +--x-Direction First
+ ! + ~~~~~~~~~~~~~~~~~
+ if(mod(numdps, 2) == 0) then
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz7(i, j, k) = &
+ -WTxyz3(i, j, k) * WTxy5(i, j) &
+ + WTxyz5(i, j, k) * WTxy5(ip1(i), j) &
+ + WTxyz3(im1(i), j, k) * WTxy5(im1(i), j) &
+ - WTxyz5(im1(i), j, k) * WTxy5(i, j)
+
+ WTxy3(i, j) = WTxy3(i, j) &
+ + WTxyz7(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz8(i, j, k) = &
+ -WTxyz4(i, j, k) * WTxy3(i, j) &
+ + WTxyz6(i, j, k) * WTxy3(i, jp1(j)) &
+ + WTxyz4(i, jm1(j), k) * WTxy3(i, jm1(j)) &
+ - WTxyz6(i, jm1(j), k) * WTxy3(i, j)
+
+ WTxy3(i, j) = WTxy3(i, j) &
+ + WTxyz8(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ ! +--y-Direction First
+ ! + ~~~~~~~~~~~~~~~~~
+ else
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz7(i, j, k) = &
+ -WTxyz4(i, j, k) * WTxy5(i, j) &
+ + WTxyz6(i, j, k) * WTxy5(i, jp1(j)) &
+ + WTxyz4(i, jm1(j), k) * WTxy5(i, jm1(j)) &
+ - WTxyz6(i, jm1(j), k) * WTxy5(i, j)
+
+ WTxy3(i, j) = WTxy3(i, j) &
+ + WTxyz7(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WTxyz8(i, j, k) = &
+ -WTxyz3(i, j, k) * WTxy3(i, j) &
+ + WTxyz5(i, j, k) * WTxy3(ip1(i), j) &
+ + WTxyz3(im1(i), j, k) * WTxy3(im1(i), j) &
+ - WTxyz5(im1(i), j, k) * WTxy3(i, j)
+
+ WTxy3(i, j) = WTxy3(i, j) &
+ + WTxyz8(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ endif
+
+ ! +--Conservative Scheme order 4
+ ! + ===========================
+
+ if(norder == 4) then
+ norder = -1
+
+ ! +--Time Splitting
+ ! + --------------
+
+ ! +--Parameters
+ ! + ~~~~~~~~~~
+ if(mod(numdps, 2) == 0) then
+ idir_x = 2
+ jdir_y = 3
+ else
+ idir_x = 3
+ jdir_y = 2
+ endif
+
+ ! +--Auxiliary Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ WTxy3(i, j) = WTxy5(i, j)
+ WTxy4(i, j) = WTxy5(i, j)
+ enddo
+ enddo
+
+ ! +--1D Computation
+ ! + --------------
+
+401 continue
+
+ if(idir_x == 0 .or. &
+ jdir_y == 3) go to 402
+
+ ! +--x-Direction here
+ ! + ~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ cnpx(i) = WTxyz3(i, j, k)
+ cnmx(i) = WTxyz5(i, j, k)
+ vecx(i) = WTxy2(i, j)
+ enddo
+ cnpx(0) = WTxyz3(1, j, k)
+ cnpx(mxx) = WTxyz3(mx, j, k)
+ cnmx(0) = WTxyz5(1, j, k)
+ cnmx(mxx) = WTxyz5(mx, j, k)
+ vecx(0) = WTxy2(1, j)
+ vecx(mxx) = WTxy2(mx, j)
+
+ ! + ********
+ call ADVbot_4(flux, vecx, aa0x, aa1x, aa2x, aa3x, aa4x, &
+ cnpx, cnmx, sipx, simx, sidx, mxx, 1)
+ ! + ********
+
+ do i = 1, mx
+ WTxyz7(i, j, k) = -flux(i) + flux(im1(i))
+ enddo
+
+ do i = 1, mx
+ WTxy3(i, j) = WTxy3(i, j) + WTxyz7(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Assignation in case of Time Splitting
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(idir_x > 1 .or. &
+ jdir_y > 1) then
+ do j = 1, my
+ do i = 1, mx
+ WTxy1(i, j) = WTxy3(i, j)
+ WTxy4(i, j) = WTxy3(i, j)
+ enddo
+ enddo
+ endif
+
+ idir_x = 0
+
+402 continue
+
+ if(idir_x == 0 .and. &
+ jdir_y == 0) go to 403
+
+ ! +--y-Direction here
+ ! + ~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do i = 1, mx
+ do j = 1, my
+ cnpy(j) = WTxyz4(i, j, k)
+ cnmy(j) = WTxyz6(i, j, k)
+ vecy(j) = WTxy1(i, j)
+ enddo
+ cnpy(0) = WTxyz4(i, 1, k)
+ cnpy(myy) = WTxyz4(i, my, k)
+ cnmy(0) = WTxyz6(i, 1, k)
+ cnmy(myy) = WTxyz6(i, my, k)
+ vecy(0) = WTxy1(i, 1)
+ vecy(myy) = WTxy1(i, my)
+
+ ! + ********
+ call ADVbot_4(fluy, vecy, aa0y, aa1y, aa2y, aa3y, aa4y, &
+ cnpy, cnmy, sipy, simy, sidy, myy, 1)
+ ! + ********
+
+ do j = 1, my
+ WTxyz8(i, j, k) = -fluy(j) + fluy(jm1(j))
+ enddo
+
+ do j = 1, my
+ WTxy4(i, j) = WTxy4(i, j) + WTxyz8(i, j, k) * dsigm1(k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Assignation in case of Time Splitting
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(idir_x > 1 .or. &
+ jdir_y > 1) then
+ do j = 1, my
+ do i = 1, mx
+ WTxy2(i, j) = WTxy4(i, j)
+ WTxy3(i, j) = WTxy4(i, j)
+ enddo
+ enddo
+ endif
+
+ jdir_y = 0
+
+ go to 401
+403 continue
+ endif
+
+ ! +--Update
+ ! + ======
+ do j = 1, my
+ do i = 1, mx
+ ! New Pressure Thickness
+ pstDYn(i, j) = WTxy3(i, j)
+
+ ! New Pressure Thickness Increment
+ WTxy3(i, j) = pstDY(i, j) - WTxy3(i, j)
+
+ enddo
+ enddo
+ ! ++++++++++++++++++++++++++++++++++
+ ! +...Non Centered Schemes (END) +
+ ! ++++++++++++++++++++++++++++++++++
+ endif
+ ! +++++++++++++++++++++
+ ! +--ERROR TEST (END) +
+ ! +++++++++++++++++++++
+ endif
+ if(norder >= 0) &
+ stop '++++++++ Horizontal Advection badly conditioned ++++++++++++'
+ ! ++++++++++++++++++++++++++
+ ! +--EXPLICIT SCHEME (END) +
+ ! ++++++++++++++++++++++++++
+ endif
+
+ ! +--Vertical Wind Speed (sigma coordinate)
+ ! + ======================================
+
+ ! +--Staggered Vertical Grid
+ ! + -----------------------
+
+ if(itFast == 1) ntpsig = 0
+
+ ntpsig = 1 + ntpsig
+
+ CFLzDY = 0.0
+
+ !$OMP PARALLEL do private (i,j,k) reduction (+:CFLzDY)
+ do j = 1, my
+ if(itFast == 1) then
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ psigad(i, j, k) = 0.
+ enddo
+ ! end do
+ enddo
+ endif
+
+ if(staggr) then
+ ! cCA usual setting go here
+ ! do j=1,my
+ do i = 1, mx
+ WTxyz3(i, j, 1) = sigmid(2) * WTxy3(i, j) &
+ + dsigm1(1) * (WTxyz7(i, j, 1) + WTxyz8(i, j, 1))
+ enddo
+ ! end do
+
+ do k = kp1(1), mmz
+ ! do j=1,my
+ do i = 1, mx
+ ! +... Computation of p*Sigma. BETWEEN Sigma Levels
+ WTxyz3(i, j, k) = dsigm1(k) * ( &
+ WTxy3(i, j) + (WTxyz7(i, j, k) + WTxyz8(i, j, k))) + WTxyz3(i, j, k - 1)
+ enddo
+ ! end do
+ enddo
+ else
+ ! +--Unstaggered Vertical Grid
+ ! + -------------------------
+ ! do j=1,my
+ do i = 1, mx
+ ! +... Open Upper Boundary Condition: WTxyz7(i,j,0)=WTxyz7(i,j,1)
+ ! + WTxyz8(i,j,0)=WTxyz8(i,j,1)
+ WTxyz3(i, j, 1) = sigma(1) * WTxy3(i, j) &
+ + sigma(1) * (WTxyz7(i, j, 1) + WTxyz8(i, j, 1))
+ enddo
+ ! end do
+
+ do k = kp1(1), mz
+ ! do j=1,my
+ do i = 1, mx
+ WTxyz3(i, j, k) = dsig_1(k - 1) * (WTxy3(i, j) &
+ + 0.50 * (WTxyz7(i, j, k) + WTxyz7(i, j, k - 1) &
+ + WTxyz8(i, j, k) + WTxyz8(i, j, k - 1))) &
+ + WTxyz3(i, j, k - 1)
+ ! +... Computation of p*Sigma. ON Sigma Levels
+
+ enddo
+ ! end do
+ enddo
+ endif
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ psigad(i, j, k) = psigad(i, j, k) + WTxyz3(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ if(((itFast == ntFast + 1) .and. .not. pImplc) .OR. &
+ ((itFast == 1) .and. pImplc)) then
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ psigDY(i, j, k) = psigad(i, j, k) / ntpsig
+ enddo
+ ! end do
+ enddo
+
+ if(locorr) then
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ psigDY(i, j, k) = psigDY(i, j, k) / dtcorr
+ enddo
+ ! end do
+ enddo
+ endif
+ endif
+
+#if(ON)
+ ! +--Simple non-hydrostatic Correction
+ ! + =================================
+
+ ! +--Filtering
+ ! + ~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ WTxy4(i, j) = &
+ zi__TE(im1(i), jp1(j)) + 2.0 * zi__TE(i, jp1(j)) &
+ + zi__TE(ip1(i), jp1(j)) &
+ + 2.0 * zi__TE(im1(i), j) + 4.0 * zi__TE(i, j) &
+ + 2.0 * zi__TE(ip1(i), j) &
+ + zi__TE(im1(i), jm1(j)) + 2.0 * zi__TE(i, jm1(j)) &
+ + zi__TE(ip1(i), jm1(j))
+ enddo
+ enddo
+ do j = 1, my
+ do i = 1, mx
+ WTxy4(i, j) = 0.0625 * WTxy4(i, j)
+ enddo
+ enddo
+
+ ! +--Correction
+ ! + ~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ ! Weisman et al., 1997, MWR125, p.541
+ CorArg = 1.0 + WTxy4(i, j) * WTxy4(i, j) / (4.0 * dx * dx)
+ CorrNH = 1.0 / sqrt(CorArg)
+ do k = 1, mz
+ psigDY(i, j, k) = psigDY(i, j, k) * CorrNH
+ enddo
+ enddo
+ enddo
+#endif
+
+ ! +--Vertical Velocity (sigma coordinates)
+ ! + =====================================
+
+ if(staggr) then
+ do k = 1, mz
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ wsigDY(i, j, k) = psigDY(i, j, k) / pstDYn(i, j)
+ enddo
+ ! end do
+ enddo
+ else
+ do k = 1, mz1
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ wsigDY(i, j, k) = (psigDY(i, j, k) + psigDY(i, j, kp1(k))) * 0.5 &
+ / pstDYn(i, j)
+ enddo
+ ! end do
+ enddo
+ k = mz
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ wsigDY(i, j, k) = psigDY(i, j, k) * 0.5 &
+ / pstDYn(i, j)
+ enddo
+ ! end do
+ endif
+
+ ! +--Maximum Vertical Courant Number
+ ! + ===============================
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ CFLzDY = max(CFLzDY &
+ , abs(wsigDY(i, j, k)) * 2.0 * dt / dsigm1(k))
+ enddo
+ ! end do
+ enddo
+
+ enddo
+ !$OMP END PARALLEL DO
+
+#if(OM)
+ ! +--Slip condition for Mountain Wave Experiments
+ ! + ============================================
+ do j = 1, my
+ do i = 1, mx
+ psigDY(i, j, mz) = 0.0
+ enddo
+ enddo
+#endif
+ return
+endsubroutine DYNdps_mp
diff --git a/MAR/code_mar/dynfil_1d.f90 b/MAR/code_mar/dynfil_1d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ea5430d4dba0ddb81af7514da84ce087136ef90e
--- /dev/null
+++ b/MAR/code_mar/dynfil_1d.f90
@@ -0,0 +1,123 @@
+#include "MAR_pp.def"
+subroutine DYNfil_1D(f1_fil, e1_fil, k1_fil)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FILTER (1-D) 24-09-2001 MAR |
+ ! | subroutine DYNfil_1D is used to Filter Horizontal Fields in 2D Code |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: f1_fil : filtered variable |
+ ! | ^^^^^ e1_fil : value of the selectivity parameter |
+ ! | k1_fil : vertical dimension of the problem |
+ ! | |
+ ! | OUTPUT:(via common block) |
+ ! | ^^^^^^ f1_fil |
+ ! | |
+ ! | LATERAL BOUNDARIES: |
+ ! | ^^^^^^^^^^^^^^^^^^^ |
+ ! | 1. The value of the variable is fixed at the Boundary |
+ ! | 2. Filter Selectivity Parameter may be increased near the Boundary |
+ ! | (#EP) |
+ ! | |
+ ! | REFER. : Alpert (1981), J.Comput.Phys. 44, pp.212--219 |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marphy
+ use mardim
+ use marvec
+ ! +
+ implicit none
+ ! +
+ real f1_fil(mx, my, mz), e1_fil(mz)
+ integer k1_fil
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ integer kindex
+ integer m, i
+ integer m1, m2
+ real aa, bb
+#if(EP)
+ integer m3, m4
+ real delt2, delt3, delt4
+#endif
+ ! +
+ ! +
+ ! +--Initialisation of the Gaussian Elimination Algorithm
+ ! + ====================================================
+ ! +
+ m = mx
+ m1 = m - 1
+ m2 = m - 2
+#if(EP)
+ m3 = m - 3
+ m4 = m - 4
+#endif
+ ! +
+ do kindex = 1, k1_fil
+ ! +
+ vecx1(1) = 0.0
+ vecx2(1) = 1.0
+ vecx1(m) = 0.0
+ vecx2(m) = 1.0
+ vecx4(1) = f1_fil(1, 1, kindex)
+ vecx4(m) = f1_fil(m, 1, kindex)
+ ! +
+ delta = e1_fil(kindex)
+ ! +
+#if(EP)
+ delt4 = delta + delta
+ delt3 = delt4 + delt4
+ delt2 = delt3 + delt3
+#endif
+ ! +.. Filter Selectivity Parameter Increase near the Boundaries
+ ! +
+ aa = 1.0 - delta
+ bb = 2.0 * (1.0 + delta)
+ ! +
+ do i = 2, m1
+ vecx1(i) = aa
+ vecx2(i) = bb
+ vecx4(i) = f1_fil(i - 1, 1, kindex) + 2.0 * f1_fil(i, 1, kindex) &
+ + f1_fil(i + 1, 1, kindex)
+ enddo
+ ! +
+#if(EP)
+ vecx1(2) = 1.0 - delt2
+ vecx1(3) = 1.0 - delt3
+ vecx1(4) = 1.0 - delt4
+ vecx2(2) = 2.0 * (1.0 + delt2)
+ vecx2(3) = 2.0 * (1.0 + delt3)
+ vecx2(4) = 2.0 * (1.0 + delt4)
+ vecx1(m2) = vecx1(2)
+ vecx1(m3) = vecx1(3)
+ vecx1(m4) = vecx1(4)
+ vecx2(m2) = vecx2(2)
+ vecx2(m3) = vecx2(3)
+ vecx2(m4) = vecx2(4)
+#endif
+ ! +
+ do i = 1, m
+ vecxa(i) = f1_fil(i, 1, kindex)
+ vecx5(i) = 0.
+ vecx6(i) = 0.
+ enddo
+ ! +
+ ! +
+ ! +--Gaussian Elimination Algorithm
+ ! + ==============================
+ ! +
+ ! + *********
+ call tlat(vecx1, vecx2, vecx1, vecx4, vecx5, vecx6, m, m, vecxa)
+ ! + *********
+ ! +
+ do i = 1, m
+ f1_fil(i, 1, kindex) = vecxa(i)
+ enddo
+ ! +
+ enddo
+ ! +
+ return
+endsubroutine DYNfil_1D
diff --git a/MAR/code_mar/dynfil_3d.f90 b/MAR/code_mar/dynfil_3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..96af057402a5da7854cb191e8376c9859953d9e4
--- /dev/null
+++ b/MAR/code_mar/dynfil_3d.f90
@@ -0,0 +1,256 @@
+#include "MAR_pp.def"
+subroutine DYNfil_3D(f3_fil, e3_fil, k3_fil)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FILTER (3-D) 19-11-2012-XF MAR |
+ ! | subroutine DYNfil_3D is used to Filter Horizontal Fields in 3D Code |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: f3_fil(i,j,k): variable to be filtered (in surface k) |
+ ! | ^^^^^ e3_fil( k): value of the selectivity parameter |
+ ! | k3_fil : vertical dimension of the variable |
+ ! | |
+ ! | OUTPUT: f3_fil(i,j,k) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | LATERAL BOUNDARIES: |
+ ! | ^^^^^^^^^^^^^^^^^^^ |
+ ! | 1. The value of the variable is fixed at the Boundary |
+ ! | 2. Filter Selectivity Parameter may be increased near the Boundary |
+ ! | (#EP) |
+ ! | |
+ ! | REFER. : Raymond and Garder, MWR 116, Jan 1988, p209 |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ real f3_fil(mx, my, mz), e3_fil(mz)
+ integer k3_fil
+
+ ! +--Local Variables
+ ! + ================
+
+ real eps2(mz)
+ real eps3(mz)
+ real eps4(mz)
+ real eps5(mz)
+ real a1_fil(1:mx, mz), b1_fil(1:mx, mz), aa_fil(mz)
+ real a2_fil(1:my, mz), b2_fil(1:my, mz), bb_fil(mz)
+
+ ! +--Initialisation
+ ! + ==============
+
+ m = mx
+ m1 = mx1
+ m2 = mx2
+#if(EP)
+ m3 = mx - 3
+ m4 = mx - 4
+#endif
+ mn = my
+ mn1 = my1
+ mn2 = my2
+#if(EP)
+ mn3 = my - 3
+ mn4 = my - 4
+#endif
+
+ ! +--1st Matrix Initialisation
+ ! + -------------------------
+
+ do k = 1, k3_fil
+ a1_fil(1, k) = 0.0
+ b1_fil(1, k) = 1.0
+ a1_fil(mx, k) = 0.0
+ b1_fil(mx, k) = 1.0
+#if(EP)
+ ! Pour diminution de la sectivite du filtre vers les bords
+ ! (augmentation --X 2-- parametre selectivite a chaque pas spatial)
+ eps5(k) = e3_fil(k) + e3_fil(k)
+ eps4(k) = eps5(k) + eps5(k)
+ eps3(k) = eps4(k) + eps4(k)
+ eps2(k) = eps3(k) + eps3(k)
+#endif
+
+ aa_fil(k) = 1.0 - e3_fil(k)
+ bb_fil(k) = 2.0 * (1.0 + e3_fil(k))
+
+ do i = ip11, mx1
+ a1_fil(i, k) = aa_fil(k)
+ b1_fil(i, k) = bb_fil(k)
+ enddo
+#if(EP)
+ a1_fil(2, k) = 1.0 - eps2(k)
+ a1_fil(3, k) = 1.0 - eps3(k)
+ a1_fil(4, k) = 1.0 - eps4(k)
+ a1_fil(5, k) = 1.0 - eps5(k)
+ b1_fil(2, k) = 2.0 * (1.0 + eps2(k))
+ b1_fil(3, k) = 2.0 * (1.0 + eps3(k))
+ b1_fil(4, k) = 2.0 * (1.0 + eps4(k))
+ b1_fil(5, k) = 2.0 * (1.0 + eps5(k))
+ a1_fil(m1, k) = a1_fil(2, k)
+ a1_fil(m2, k) = a1_fil(3, k)
+ a1_fil(m3, k) = a1_fil(4, k)
+ a1_fil(m4, k) = a1_fil(5, k)
+ b1_fil(m1, k) = b1_fil(2, k)
+ b1_fil(m2, k) = b1_fil(3, k)
+ b1_fil(m3, k) = b1_fil(4, k)
+ b1_fil(m4, k) = b1_fil(5, k)
+#endif
+
+ ! +--2th Matrix Initialisation
+ ! + -------------------------
+
+ a2_fil(1, k) = 0.0
+ b2_fil(1, k) = 1.0
+ a2_fil(my, k) = 0.0
+ b2_fil(my, k) = 1.0
+
+ do j = jp11, my1
+ a2_fil(j, k) = aa_fil(k)
+ b2_fil(j, k) = bb_fil(k)
+ enddo
+#if(EP)
+ a2_fil(2, k) = a1_fil(2, k)
+ a2_fil(3, k) = a1_fil(3, k)
+ a2_fil(4, k) = a1_fil(4, k)
+ a2_fil(5, k) = a1_fil(5, k)
+ b2_fil(2, k) = b1_fil(2, k)
+ b2_fil(3, k) = b1_fil(3, k)
+ b2_fil(4, k) = b1_fil(4, k)
+ b2_fil(5, k) = b1_fil(5, k)
+ a2_fil(mn1, k) = a1_fil(2, k)
+ a2_fil(mn2, k) = a1_fil(3, k)
+ a2_fil(mn3, k) = a1_fil(4, k)
+ a2_fil(mn4, k) = a1_fil(5, k)
+ b2_fil(mn1, k) = b1_fil(2, k)
+ b2_fil(mn2, k) = b1_fil(3, k)
+ b2_fil(mn3, k) = b1_fil(4, k)
+ b2_fil(mn4, k) = b1_fil(5, k)
+#endif
+
+ enddo
+
+ ! +--1st Equations System
+ ! + ====================
+
+ ! +--Gaussian Elimination Algorithm: Set Up
+ ! + --------------------------------------
+
+ do k = 1, k3_fil
+ do j = jp11, my1
+
+ WTxyz4(1, j, k) = &
+ f3_fil(1, jm1(j), k) + 2.0 * f3_fil(1, j, k) + &
+ f3_fil(1, jp1(j), k)
+ WTxyz4(mx, j, k) = &
+ f3_fil(mx, jm1(j), k) + 2.0 * f3_fil(mx, j, k) + &
+ f3_fil(mx, jp1(j), k)
+
+ do i = ip11, mx1
+ WTxyz4(i, j, k) = &
+ f3_fil(im1(i), jp1(j), k) + 2.0 * f3_fil(i, jp1(j), k) &
+ + f3_fil(ip1(i), jp1(j), k) + &
+ 2.0 * f3_fil(im1(i), j, k) + 4.0 * &
+ f3_fil(i, j, k) &
+ + 2.0 * f3_fil(ip1(i), j, k) + &
+ f3_fil(im1(i), jm1(j), k) + 2.0 * &
+ f3_fil(i, jm1(j), k) &
+ + f3_fil(ip1(i), jm1(j), k)
+ enddo
+
+ enddo
+ enddo
+
+ ! +--Gaussian Elimination Algorithm: F-B Sweep ==> WTxyz7
+ ! + ----------------------------------------------------
+ ! +
+ do k = 1, k3_fil
+ do j = 1, my
+
+ ! +--Forward Sweep
+
+ WTxyz6(1, j, k) = -a1_fil(1, k) / b1_fil(1, k)
+ WTxyz7(1, j, k) = WTxyz4(1, j, k) / b1_fil(1, k)
+ do i = ip11, mx
+ WTxyz6(i, j, k) = -a1_fil(i, k) &
+ / (a1_fil(i, k) * WTxyz6(i - 1, j, k) + b1_fil(i, k))
+ WTxyz7(i, j, k) = (WTxyz4(i, j, k) - a1_fil(i, k) * &
+ WTxyz7(i - 1, j, k)) &
+ / (a1_fil(i, k) * WTxyz6(i - 1, j, k) + b1_fil(i, k))
+ enddo
+
+ ! +--Backward Sweep
+
+ do i = mx1, 1, -1
+ WTxyz7(i, j, k) = WTxyz6(i, j, k) * WTxyz7(i + 1, j, k) + &
+ WTxyz7(i, j, k)
+ enddo
+
+ enddo
+ enddo
+
+ ! +--2th Equations System
+ ! + ====================
+
+ ! +--Gaussian Elimination Algorithm: Set Up
+ ! + --------------------------------------
+
+ do k = 1, k3_fil
+ do i = ip11, mx1
+ WTxyz4(i, 1, k) = f3_fil(i, 1, k)
+ WTxyz4(i, my, k) = f3_fil(i, my, k)
+ do j = jp11, my1
+ WTxyz4(i, j, k) = WTxyz7(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Gaussian Elimination Algorithm: F-B Sweep ==> WTxyz7
+ ! + ----------------------------------------------------
+
+ do k = 1, k3_fil
+ do i = 1, mx
+
+ ! +--Forward Sweep
+
+ WTxyz6(i, 1, k) = -a2_fil(1, k) / b2_fil(1, k)
+ WTxyz7(i, 1, k) = WTxyz4(i, 1, k) / b2_fil(1, k)
+ do j = jp11, my
+ WTxyz6(i, j, k) = -a2_fil(j, k) &
+ / (a2_fil(j, k) * WTxyz6(i, j - 1, k) + b2_fil(j, k))
+ WTxyz7(i, j, k) = (WTxyz4(i, j, k) - a2_fil(j, k) * &
+ WTxyz7(i, j - 1, k)) &
+ / (a2_fil(j, k) * WTxyz6(i, j - 1, k) + b2_fil(j, k))
+ enddo
+
+ ! +--Backward Sweep
+
+ do j = my1, 1, -1
+ WTxyz7(i, j, k) = WTxyz6(i, j, k) * WTxyz7(i, j + 1, k) + &
+ WTxyz7(i, j, k)
+ enddo
+
+ enddo
+ enddo
+
+ ! +--Result
+ ! + ======
+
+ do k = 1, k3_fil
+ do j = jp11, my1
+ do i = ip11, mx1
+ f3_fil(i, j, k) = WTxyz7(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ return
+endsubroutine DYNfil_3D
diff --git a/MAR/code_mar/dynfil_3d_mp.f90 b/MAR/code_mar/dynfil_3d_mp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aa0467d21e24ef72a0da5d9766ebcfc5db8e8c04
--- /dev/null
+++ b/MAR/code_mar/dynfil_3d_mp.f90
@@ -0,0 +1,260 @@
+#include "MAR_pp.def"
+subroutine DYNfil_3D_mp(f3_fil, e3_fil, k3_fil)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FILTER (3-D) 08-12-2022 MAR |
+ ! | subroutine DYNfil_3D_mp is used to Filter Horizontal Fields in 3DCode|
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: f3_fil(i,j,k): variable to be filtered (in surface k) |
+ ! | ^^^^^ e3_fil( k): value of the selectivity parameter |
+ ! | k3_fil : vertical dimension of the variable |
+ ! | |
+ ! | OUTPUT: f3_fil(i,j,k) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | LATERAL BOUNDARIES: |
+ ! | ^^^^^^^^^^^^^^^^^^^ |
+ ! | 1. The value of the variable is fixed at the Boundary |
+ ! | 2. Filter Selectivity Parameter may be increased near the Boundary |
+ ! | (#EP) |
+ ! | |
+ ! | REFER. : Raymond and Garder, MWR 116, Jan 1988, p209 |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ real f3_fil(mx, my, mz), e3_fil(mz),flag
+ integer k3_fil
+
+ real eps2(mz)
+ real eps3(mz)
+ real eps4(mz)
+ real eps5(mz)
+ real a1_fil(1:mx, mz), b1_fil(1:mx, mz), aa_fil(mz)
+ real a2_fil(1:my, mz), b2_fil(1:my, mz), bb_fil(mz)
+
+ ! +--Initialisation
+ ! + ==============
+
+ m = mx
+ m1 = mx1
+ m2 = mx2
+#if(EP)
+ m3 = mx - 3
+ m4 = mx - 4
+#endif
+ mn = my
+ mn1 = my1
+ mn2 = my2
+#if(EP)
+ mn3 = my - 3
+ mn4 = my - 4
+#endif
+
+ ! +--1st Matrix Initialisation
+ ! + -------------------------
+
+!$OMP PARALLEL DO default(shared) &
+!$OMP private(a1_fil,b1_fil,a2_fil,b2_fil,flag,WTxy4,WTxy6,WTxy7,i,j,k) &
+!$OMP schedule(dynamic)
+ do k = 1, k3_fil
+
+
+ flag = 0
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(abs(f3_fil(i, j, k)) > 1.5 * eps9) flag = 1
+ enddo
+ enddo
+
+ if(flag == 1) then
+
+ a1_fil(1, k) = 0.0
+ b1_fil(1, k) = 1.0
+ a1_fil(mx, k) = 0.0
+ b1_fil(mx, k) = 1.0
+#if(EP)
+ ! Pour diminution de la sectivite du filtre vers les bords
+ ! (augmentation --X 2-- parametre selectivite a chaque pas spatial)
+ eps5(k) = e3_fil(k) + e3_fil(k)
+ eps4(k) = eps5(k) + eps5(k)
+ eps3(k) = eps4(k) + eps4(k)
+ eps2(k) = eps3(k) + eps3(k)
+#endif
+ aa_fil(k) = 1.0 - e3_fil(k)
+ bb_fil(k) = 2.0 * (1.0 + e3_fil(k))
+
+ do i = ip11, mx1
+ a1_fil(i, k) = aa_fil(k)
+ b1_fil(i, k) = bb_fil(k)
+ enddo
+#if(EP)
+ a1_fil(2, k) = 1.0 - eps2(k)
+ a1_fil(3, k) = 1.0 - eps3(k)
+ a1_fil(4, k) = 1.0 - eps4(k)
+ a1_fil(5, k) = 1.0 - eps5(k)
+ b1_fil(2, k) = 2.0 * (1.0 + eps2(k))
+ b1_fil(3, k) = 2.0 * (1.0 + eps3(k))
+ b1_fil(4, k) = 2.0 * (1.0 + eps4(k))
+ b1_fil(5, k) = 2.0 * (1.0 + eps5(k))
+ a1_fil(m1, k) = a1_fil(2, k)
+ a1_fil(m2, k) = a1_fil(3, k)
+ a1_fil(m3, k) = a1_fil(4, k)
+ a1_fil(m4, k) = a1_fil(5, k)
+ b1_fil(m1, k) = b1_fil(2, k)
+ b1_fil(m2, k) = b1_fil(3, k)
+ b1_fil(m3, k) = b1_fil(4, k)
+ b1_fil(m4, k) = b1_fil(5, k)
+#endif
+
+ ! +--2th Matrix Initialisation
+ ! + -------------------------
+
+ a2_fil(1, k) = 0.0
+ b2_fil(1, k) = 1.0
+ a2_fil(my, k) = 0.0
+ b2_fil(my, k) = 1.0
+
+ do j = jp11, my1
+ a2_fil(j, k) = aa_fil(k)
+ b2_fil(j, k) = bb_fil(k)
+ enddo
+#if(EP)
+ a2_fil(2, k) = a1_fil(2, k)
+ a2_fil(3, k) = a1_fil(3, k)
+ a2_fil(4, k) = a1_fil(4, k)
+ a2_fil(5, k) = a1_fil(5, k)
+ b2_fil(2, k) = b1_fil(2, k)
+ b2_fil(3, k) = b1_fil(3, k)
+ b2_fil(4, k) = b1_fil(4, k)
+ b2_fil(5, k) = b1_fil(5, k)
+ a2_fil(mn1, k) = a1_fil(2, k)
+ a2_fil(mn2, k) = a1_fil(3, k)
+ a2_fil(mn3, k) = a1_fil(4, k)
+ a2_fil(mn4, k) = a1_fil(5, k)
+ b2_fil(mn1, k) = b1_fil(2, k)
+ b2_fil(mn2, k) = b1_fil(3, k)
+ b2_fil(mn3, k) = b1_fil(4, k)
+ b2_fil(mn4, k) = b1_fil(5, k)
+#endif
+
+ ! end do
+
+ ! +--1st Equations System
+ ! + ====================
+
+ ! +--Gaussian Elimination Algorithm: Set Up
+ ! + --------------------------------------
+
+ ! do k=1,k3_fil
+ do j = jp11, my1
+
+ WTxy4(1, j) = &
+ f3_fil(1, jm1(j), k) + 2.0 * f3_fil(1, j, k) + f3_fil(1, jp1(j), k)
+ WTxy4(mx, j) = &
+ f3_fil(mx, jm1(j), k) + 2.0 * f3_fil(mx, j, k) + f3_fil(mx, jp1(j), k)
+
+ do i = ip11, mx1
+ WTxy4(i, j) = &
+ f3_fil(im1(i), jp1(j), k) + 2.0 * f3_fil(i, jp1(j), k) + &
+ f3_fil(ip1(i), jp1(j), k) + &
+ 2.0 * f3_fil(im1(i), j, k) + 4.0 * f3_fil(i, j, k) + &
+ 2.0 * f3_fil(ip1(i), j, k) + &
+ f3_fil(im1(i), jm1(j), k) + 2.0 * f3_fil(i, jm1(j), k) + &
+ f3_fil(ip1(i), jm1(j), k)
+ enddo
+
+ enddo
+ ! end do
+
+ ! +--Gaussian Elimination Algorithm: F-B Sweep ==> WTxy7
+ ! + ----------------------------------------------------
+ ! +
+ ! do k=1,k3_fil
+ do j = 1, my
+
+ ! +--Forward Sweep
+
+ WTxy6(1, j) = -a1_fil(1, k) / b1_fil(1, k)
+ WTxy7(1, j) = WTxy4(1, j) / b1_fil(1, k)
+ do i = ip11, mx
+ WTxy6(i, j) = -a1_fil(i, k) &
+ / (a1_fil(i, k) * WTxy6(i - 1, j) + b1_fil(i, k))
+ WTxy7(i, j) = (WTxy4(i, j) - a1_fil(i, k) * WTxy7(i - 1, j)) &
+ / (a1_fil(i, k) * WTxy6(i - 1, j) + b1_fil(i, k))
+ enddo
+
+ ! +--Backward Sweep
+
+ do i = mx1, 1, -1
+ WTxy7(i, j) = WTxy6(i, j) * WTxy7(i + 1, j) + WTxy7(i, j)
+ enddo
+
+ enddo
+ ! end do
+
+ ! +--2th Equations System
+ ! + ====================
+
+ ! +--Gaussian Elimination Algorithm: Set Up
+ ! + --------------------------------------
+
+ ! do k=1,k3_fil
+ do i = ip11, mx1
+ WTxy4(i, 1) = f3_fil(i, 1, k)
+ WTxy4(i, my) = f3_fil(i, my, k)
+ do j = jp11, my1
+ WTxy4(i, j) = WTxy7(i, j)
+ enddo
+ enddo
+ ! end do
+
+ ! +--Gaussian Elimination Algorithm: F-B Sweep ==> WTxy7
+ ! + ----------------------------------------------------
+
+ ! do k=1,k3_fil
+ do i = 1, mx
+
+ ! +--Forward Sweep
+
+ WTxy6(i, 1) = -a2_fil(1, k) / b2_fil(1, k)
+ WTxy7(i, 1) = WTxy4(i, 1) / b2_fil(1, k)
+ do j = jp11, my
+ WTxy6(i, j) = -a2_fil(j, k) &
+ / (a2_fil(j, k) * WTxy6(i, j - 1) + b2_fil(j, k))
+ WTxy7(i, j) = (WTxy4(i, j) - a2_fil(j, k) * WTxy7(i, j - 1)) &
+ / (a2_fil(j, k) * WTxy6(i, j - 1) + b2_fil(j, k))
+ enddo
+
+ ! +--Backward Sweep
+
+ do j = my1, 1, -1
+ WTxy7(i, j) = WTxy6(i, j) * WTxy7(i, j + 1) + WTxy7(i, j)
+ enddo
+
+ enddo
+ ! end do
+
+ ! +--Result
+ ! + ======
+
+ ! do k=1,k3_fil
+ do j = jp11, my1
+ do i = ip11, mx1
+ f3_fil(i, j, k) = WTxy7(i, j)
+ enddo
+ enddo
+ endif
+ enddo
+!$OMP END PARALLEL DO
+
+ return
+endsubroutine DYNfil_3D_mp
diff --git a/MAR/code_mar/dynfil_3d_mp2.f90 b/MAR/code_mar/dynfil_3d_mp2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f26e5418f51bf5aec1c087a6b4229b9ea775a5f2
--- /dev/null
+++ b/MAR/code_mar/dynfil_3d_mp2.f90
@@ -0,0 +1,291 @@
+#include "MAR_pp.def"
+subroutine DYNfil_3D_mp2(f3_fil, v3_fil, e3_fil, k3_fil)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FILTER (3-D) 07-09-2017-XF MAR |
+ ! | subroutine DYNfil_3D_mp is used to Filter Horizontal Fields in 3DCode|
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: f3_fil(i,j,k): variable to be filtered (in surface k) |
+ ! | ^^^^^ e3_fil( k): value of the selectivity parameter |
+ ! | k3_fil : vertical dimension of the variable |
+ ! | |
+ ! | OUTPUT: f3_fil(i,j,k) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | LATERAL BOUNDARIES: |
+ ! | ^^^^^^^^^^^^^^^^^^^ |
+ ! | 1. The value of the variable is fixed at the Boundary |
+ ! | 2. Filter Selectivity Parameter may be increased near the Boundary |
+ ! | (#EP) |
+ ! | |
+ ! | REFER. : Raymond and Garder, MWR 116, Jan 1988, p209 |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ real f3_fil(mx, my, mz), e3_fil(mz), v3_fil(mx, my, mz)
+ integer k3_fil
+
+ real WVxy4(mx, my), WVxy6(mx, my), WVxy7(mx, my)
+
+ real eps2(mz)
+ real eps3(mz)
+ real eps4(mz)
+ real eps5(mz)
+ real a1_fil(1:mx, mz), b1_fil(1:mx, mz), aa_fil(mz)
+ real a2_fil(1:my, mz), b2_fil(1:my, mz), bb_fil(mz)
+
+ ! +--Initialisation
+ ! + ==============
+
+ m = mx
+ m1 = mx1
+ m2 = mx2
+#if(EP)
+ m3 = mx - 3
+ m4 = mx - 4
+#endif
+ mn = my
+ mn1 = my1
+ mn2 = my2
+#if(EP)
+ mn3 = my - 3
+ mn4 = my - 4
+#endif
+
+ ! +--1st Matrix Initialisation
+ ! + -------------------------
+
+!$OMP PARALLEL do default(shared) &
+!$OMP private(a1_fil,b1_fil,a2_fil,b2_fil, &
+!$OMP WTxy4,WTxy6,WTxy7,i,j,k,WVxy4,WVxy6,WVxy7)
+ do k = 1, k3_fil
+ a1_fil(1, k) = 0.0
+ b1_fil(1, k) = 1.0
+ a1_fil(mx, k) = 0.0
+ b1_fil(mx, k) = 1.0
+#if(EP)
+ ! Pour diminution de la sectivite du filtre vers les bords
+ ! (augmentation --X 2-- parametre selectivite a chaque pas spatial)
+ eps5(k) = e3_fil(k) + e3_fil(k)
+ eps4(k) = eps5(k) + eps5(k)
+ eps3(k) = eps4(k) + eps4(k)
+ eps2(k) = eps3(k) + eps3(k)
+#endif
+
+ aa_fil(k) = 1.0 - e3_fil(k)
+ bb_fil(k) = 2.0 * (1.0 + e3_fil(k))
+
+ do i = ip11, mx1
+ a1_fil(i, k) = aa_fil(k)
+ b1_fil(i, k) = bb_fil(k)
+ enddo
+#if(EP)
+ a1_fil(2, k) = 1.0 - eps2(k)
+ a1_fil(3, k) = 1.0 - eps3(k)
+ a1_fil(4, k) = 1.0 - eps4(k)
+ a1_fil(5, k) = 1.0 - eps5(k)
+ b1_fil(2, k) = 2.0 * (1.0 + eps2(k))
+ b1_fil(3, k) = 2.0 * (1.0 + eps3(k))
+ b1_fil(4, k) = 2.0 * (1.0 + eps4(k))
+ b1_fil(5, k) = 2.0 * (1.0 + eps5(k))
+ a1_fil(m1, k) = a1_fil(2, k)
+ a1_fil(m2, k) = a1_fil(3, k)
+ a1_fil(m3, k) = a1_fil(4, k)
+ a1_fil(m4, k) = a1_fil(5, k)
+ b1_fil(m1, k) = b1_fil(2, k)
+ b1_fil(m2, k) = b1_fil(3, k)
+ b1_fil(m3, k) = b1_fil(4, k)
+ b1_fil(m4, k) = b1_fil(5, k)
+#endif
+
+ ! +--2th Matrix Initialisation
+ ! + -------------------------
+
+ a2_fil(1, k) = 0.0
+ b2_fil(1, k) = 1.0
+ a2_fil(my, k) = 0.0
+ b2_fil(my, k) = 1.0
+
+ do j = jp11, my1
+ a2_fil(j, k) = aa_fil(k)
+ b2_fil(j, k) = bb_fil(k)
+ enddo
+#if(EP)
+ a2_fil(2, k) = a1_fil(2, k)
+ a2_fil(3, k) = a1_fil(3, k)
+ a2_fil(4, k) = a1_fil(4, k)
+ a2_fil(5, k) = a1_fil(5, k)
+ b2_fil(2, k) = b1_fil(2, k)
+ b2_fil(3, k) = b1_fil(3, k)
+ b2_fil(4, k) = b1_fil(4, k)
+ b2_fil(5, k) = b1_fil(5, k)
+ a2_fil(mn1, k) = a1_fil(2, k)
+ a2_fil(mn2, k) = a1_fil(3, k)
+ a2_fil(mn3, k) = a1_fil(4, k)
+ a2_fil(mn4, k) = a1_fil(5, k)
+ b2_fil(mn1, k) = b1_fil(2, k)
+ b2_fil(mn2, k) = b1_fil(3, k)
+ b2_fil(mn3, k) = b1_fil(4, k)
+ b2_fil(mn4, k) = b1_fil(5, k)
+#endif
+
+ ! end do
+
+ ! +--1st Equations System
+ ! + ====================
+
+ ! +--Gaussian Elimination Algorithm: Set Up
+ ! + --------------------------------------
+
+ ! do k=1,k3_fil
+ do j = jp11, my1
+
+ WTxy4(1, j) = &
+ f3_fil(1, jm1(j), k) + 2.0 * f3_fil(1, j, k) + f3_fil(1, jp1(j), k)
+ WTxy4(mx, j) = &
+ f3_fil(mx, jm1(j), k) + 2.0 * f3_fil(mx, j, k) + f3_fil(mx, jp1(j), k)
+
+ WVxy4(1, j) = &
+ v3_fil(1, jm1(j), k) + 2.0 * v3_fil(1, j, k) + v3_fil(1, jp1(j), k)
+ WVxy4(mx, j) = &
+ v3_fil(mx, jm1(j), k) + 2.0 * v3_fil(mx, j, k) + v3_fil(mx, jp1(j), k)
+
+ do i = ip11, mx1
+ WTxy4(i, j) = &
+ f3_fil(im1(i), jp1(j), k) + 2.0 * f3_fil(i, jp1(j), k) &
+ + f3_fil(ip1(i), jp1(j), k) + &
+ 2.0 * f3_fil(im1(i), j, k) + 4.0 * f3_fil(i, j, k) &
+ + 2.0 * f3_fil(ip1(i), j, k) + &
+ f3_fil(im1(i), jm1(j), k) + 2.0 * f3_fil(i, jm1(j), k) &
+ + f3_fil(ip1(i), jm1(j), k)
+
+ WVxy4(i, j) = &
+ v3_fil(im1(i), jp1(j), k) + 2.0 * v3_fil(i, jp1(j), k) &
+ + v3_fil(ip1(i), jp1(j), k) + &
+ 2.0 * v3_fil(im1(i), j, k) + 4.0 * v3_fil(i, j, k) &
+ + 2.0 * v3_fil(ip1(i), j, k) + &
+ v3_fil(im1(i), jm1(j), k) + 2.0 * v3_fil(i, jm1(j), k) &
+ + v3_fil(ip1(i), jm1(j), k)
+
+ enddo
+
+ enddo
+ ! end do
+
+ ! +--Gaussian Elimination Algorithm: F-B Sweep ==> WTxy7
+ ! + ----------------------------------------------------
+ ! +
+ ! do k=1,k3_fil
+ do j = 1, my
+
+ ! +--Forward Sweep
+
+ WTxy6(1, j) = -a1_fil(1, k) / b1_fil(1, k)
+ WTxy7(1, j) = WTxy4(1, j) / b1_fil(1, k)
+
+ WVxy6(1, j) = -a1_fil(1, k) / b1_fil(1, k)
+ WVxy7(1, j) = WVxy4(1, j) / b1_fil(1, k)
+
+ do i = ip11, mx
+ WTxy6(i, j) = -a1_fil(i, k) &
+ / (a1_fil(i, k) * WTxy6(i - 1, j) + b1_fil(i, k))
+ WTxy7(i, j) = (WTxy4(i, j) - a1_fil(i, k) * WTxy7(i - 1, j)) &
+ / (a1_fil(i, k) * WTxy6(i - 1, j) + b1_fil(i, k))
+
+ WVxy6(i, j) = -a1_fil(i, k) &
+ / (a1_fil(i, k) * WVxy6(i - 1, j) + b1_fil(i, k))
+ WVxy7(i, j) = (WVxy4(i, j) - a1_fil(i, k) * WVxy7(i - 1, j)) &
+ / (a1_fil(i, k) * WVxy6(i - 1, j) + b1_fil(i, k))
+
+ enddo
+
+ ! +--Backward Sweep
+
+ do i = mx1, 1, -1
+ WTxy7(i, j) = WTxy6(i, j) * WTxy7(i + 1, j) + WTxy7(i, j)
+ WVxy7(i, j) = WVxy6(i, j) * WVxy7(i + 1, j) + WVxy7(i, j)
+ enddo
+
+ enddo
+ ! end do
+
+ ! +--2th Equations System
+ ! + ====================
+
+ ! +--Gaussian Elimination Algorithm: Set Up
+ ! + --------------------------------------
+
+ ! do k=1,k3_fil
+ do i = ip11, mx1
+ WTxy4(i, 1) = f3_fil(i, 1, k)
+ WTxy4(i, my) = f3_fil(i, my, k)
+ WVxy4(i, 1) = v3_fil(i, 1, k)
+ WVxy4(i, my) = v3_fil(i, my, k)
+ do j = jp11, my1
+ WTxy4(i, j) = WTxy7(i, j)
+ WVxy4(i, j) = WVxy7(i, j)
+ enddo
+ enddo
+ ! end do
+
+ ! +--Gaussian Elimination Algorithm: F-B Sweep ==> WTxy7
+ ! + ----------------------------------------------------
+
+ ! do k=1,k3_fil
+ do i = 1, mx
+
+ ! +--Forward Sweep
+
+ WTxy6(i, 1) = -a2_fil(1, k) / b2_fil(1, k)
+ WTxy7(i, 1) = WTxy4(i, 1) / b2_fil(1, k)
+
+ WVxy6(i, 1) = -a2_fil(1, k) / b2_fil(1, k)
+ WVxy7(i, 1) = WVxy4(i, 1) / b2_fil(1, k)
+
+ do j = jp11, my
+ WTxy6(i, j) = -a2_fil(j, k) &
+ / (a2_fil(j, k) * WTxy6(i, j - 1) + b2_fil(j, k))
+ WTxy7(i, j) = (WTxy4(i, j) - a2_fil(j, k) * WTxy7(i, j - 1)) &
+ / (a2_fil(j, k) * WTxy6(i, j - 1) + b2_fil(j, k))
+
+ WVxy6(i, j) = -a2_fil(j, k) &
+ / (a2_fil(j, k) * WVxy6(i, j - 1) + b2_fil(j, k))
+ WVxy7(i, j) = (WVxy4(i, j) - a2_fil(j, k) * WVxy7(i, j - 1)) &
+ / (a2_fil(j, k) * WVxy6(i, j - 1) + b2_fil(j, k))
+
+ enddo
+
+ ! +--Backward Sweep
+
+ do j = my1, 1, -1
+ WTxy7(i, j) = WTxy6(i, j) * WTxy7(i, j + 1) + WTxy7(i, j)
+ WVxy7(i, j) = WVxy6(i, j) * WVxy7(i, j + 1) + WVxy7(i, j)
+ enddo
+
+ enddo
+ ! end do
+
+ ! +--Result
+ ! + ======
+
+ ! do k=1,k3_fil
+ do j = jp11, my1
+ do i = ip11, mx1
+ f3_fil(i, j, k) = WTxy7(i, j)
+ v3_fil(i, j, k) = WVxy7(i, j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+ return
+endsubroutine DYNfil_3D_mp2
diff --git a/MAR/code_mar/dyngpo.f90 b/MAR/code_mar/dyngpo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..14352484dfc60beabe57ad0e8e74c3f5c406baee
--- /dev/null
+++ b/MAR/code_mar/dyngpo.f90
@@ -0,0 +1,87 @@
+subroutine dyngpo_mp
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FAST 16-12-2000 MAR |
+ ! | subroutine DYNgpo contains the Integration of Hydrostatic Relation |
+ ! | and the Computation of Real Temperature t [K] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ pktaDY(mx,my,mzz): Reduced Potential Temperature |
+ ! | gplvDY(mx,my,mzz): Surface Geopotential (i.e. for k=mzz) |
+ ! | virDY(mx,my,mz) : Air Loading by water vapor & hydrometeors |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ pkDY(mx,my,mz) : Exner Potential |
+ ! | tairDY(mx,my,mz) : Temperature [K] |
+ ! | gplvDY(mx,my,mzz): Geopotential [m2/s2] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ real ab
+
+ ! +--EXNER Potential and Temperature
+ ! + ===============================
+ ab = 0.5 * (1.0 - sigmid(mz)) / (1.0 - sigmid(mmz1))
+
+!$OMP PARALLEL DO private(i,j,k)
+ do j = 1, my
+ do k = 1, mz
+ do i = 1, mx
+ pkDY(i, j, k) = exp(cap * log(pstDYn(i, j) * sigma(k) + ptopDY))
+ tairDY(i, j, k) = pktaDY(i, j, k) * pkDY(i, j, k)
+ WTxyz1(i, j, k) = cp * pkDY(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ do k = 1, mmz1
+ ! do j=1,my
+ do i = 1, mx
+ WTxyz2(i, j, k) = cp * pkDY(i, j, kp1(k))
+ enddo
+ ! end do
+ enddo
+
+ ! do j=1,my
+ do i = 1, mx
+ WTxyz2(i, j, mz) = cp * &
+ exp(cap * log(pstDYn(i, j) + ptopDY))
+ enddo
+ ! end do
+
+ ! +--Integration of the Hydrostatic Equation / Work Arrays Reset
+ ! + ===========================================================
+
+ ! do j=1,my
+ do i = 1, mx
+ gplvDY(i, j, mz) = gplvDY(i, j, mzz) + (WTxyz2(i, j, mz) - WTxyz1(i, j, mz)) &
+ * ((1.0 + ab) * pktaDY(i, j, mz) * (1.0 + virDY(i, j, mz)) &
+ - ab * pktaDY(i, j, mmz1) * (1.0 + virDY(i, j, mmz1)))
+ WTxyz1(i, j, mz) = 0.0
+ WTxyz2(i, j, mz) = 0.0
+ enddo
+ ! end do
+
+ do k = mmz1, 1, -1
+ ! do j=1,my
+ do i = 1, mx
+ gplvDY(i, j, k) = gplvDY(i, j, kp1(k)) + (WTxyz2(i, j, k) - WTxyz1(i, j, k)) &
+ * (pktaDY(i, j, k) * (1.0 + virDY(i, j, k)) &
+ + pktaDY(i, j, kp1(k)) * (1.0 + virDY(i, j, kp1(k)))) * 0.5
+
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+ return
+endsubroutine dyngpo_mp
diff --git a/MAR/code_mar/dynloa.f90 b/MAR/code_mar/dynloa.f90
new file mode 100644
index 0000000000000000000000000000000000000000..89b85340a6b4bfa1bc2e7375a6da3e72f5397381
--- /dev/null
+++ b/MAR/code_mar/dynloa.f90
@@ -0,0 +1,146 @@
+#include "MAR_pp.def"
+subroutine dynloa
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS Mon 11-Apr-2011 MAR |
+ ! | subroutine dynloa computes the Air Loading due to the Precipitation |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ qvDY(mx,my,mz) : Air Specific Humidity [kg/kg] |
+ ! | qwHY(mx,my,mz) : Cloud Droplets Concentration [kg/kg] |
+ ! | qiHY(mx,my,mz) : Cloud ice Crystals Concentration [kg/kg] |
+ ! | qrHY(mx,my,mz) : Rain Drops Concentration [kg/kg] |
+ ! | qsHY(mx,my,mz) : Snow Flakes Concentration [kg/kg] |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ virDY(mx,my,mz) : Air Loading by Water Vapor & Hydrometeors |
+ ! | virSL(mx,my) : Air Loading by Water Vapor & Hydrometeors |
+ ! | (in the Surface Layer) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_hy
+ use mar_sl
+#if(TC)
+ use mar_tc
+#endif
+#if(BV)
+ use marvec
+#endif
+
+ implicit none
+
+ integer i, j, k, m
+#if(BV)
+ integer kdim
+ real deltav
+ data deltav/0.20/
+#endif
+
+ ! +--Air Loading including Specific Humidity (Level 0)
+ ! + =================================================
+ ! cCAiso qvDY is initialized to 0 with the compiler
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ virDY(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Air Loading including all Hydrometeors (Level 1)
+ ! + =================================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ virDY(i, j, k) = qvDY(i, j, k) &
+ - 1.64 * min(demi, qwHY(i, j, k) + qiHY(i, j, k) + &
+ qrHY(i, j, k) + qsHY(i, j, k))
+ enddo
+ enddo
+ enddo
+
+ ! +--Air Loading including Correction Factor (Level 2)
+ ! + =================================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ virDY(i, j, k) = 0.850 * virDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Lateral Boundary Conditions
+ ! + ===========================
+ do k = 1, mz
+ do j = 1, my
+ virDY(1, j, k) = virDY(ip11, j, k)
+ virDY(mx, j, k) = virDY(mx1, j, k)
+ enddo
+ do i = 1, mx
+ virDY(i, 1, k) = virDY(i, jp11, k)
+ virDY(i, my, k) = virDY(i, my1, k)
+ enddo
+ enddo
+
+#if(BV)
+ ! +--Air Loading for SBL Parameterization
+ ! + ====================================
+ dumeps(1) = deltav
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, 1) = fracSL * 0.715 * virDY(i, j, mz) &
+ + (1.0 - fracSL) * virSL(i, j)
+ enddo
+ enddo
+ kdim = 1
+ ! +--Filtering
+ ! + ---------
+ if(mmx > 1) then
+ if(mmy == 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ if(no_vec) then
+ if(openmp) then
+ ! **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! **********
+ else
+ ! **********
+ call DYNfil_3D(dumy3D, dumeps, kdim)
+ ! **********
+ endif
+ else
+ ! cCA : DYNfilv3D does not exist
+ ! ! + *********
+ ! call DYNfilv3D (dumy3D, dumeps, kdim)
+ ! ! + *********
+ endif
+ endif
+ endif
+ do j = 1, my
+ do i = 1, mx
+ virSL(i, j) = dumy3D(i, j, 1)
+ enddo
+ enddo
+#endif
+#if(OM)
+ ! +--NO Loading included in case of Mountain Waves Tests
+ ! + ===================================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ virDY(i, j, k) = 0.0d+0
+ enddo
+ enddo
+ enddo
+#endif
+ return
+endsubroutine dynloa
diff --git a/MAR/code_mar/dynqqm.f90 b/MAR/code_mar/dynqqm.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b15f63ee861972b192f6b15af42650402f7d617a
--- /dev/null
+++ b/MAR/code_mar/dynqqm.f90
@@ -0,0 +1,280 @@
+#include "MAR_pp.def"
+subroutine DYNqqm(specQt, kk, eval_s, eval_p)
+ !--------------------------------------------------------------------------+
+ ! MAR DYNAMICS SLOW Wed 08-09-2017 MAR |
+ ! |
+ ! subroutine DYNqqm restaures Water Mass |
+ ! |
+ !--------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_fi
+ use marqqm
+ use mar_wk
+ use marmagic
+
+ implicit none
+
+ logical RetroD
+ logical Set_MM
+ logical logqqm
+ common / DYNqqm_log / logqqm
+ real specQt(mx, my, mz)
+ character * 3 eval_s
+ character * 6 eval_p
+
+ ! Local Variables
+ ! ================
+
+ integer i, j, k, m
+ character * 6 eval0p
+ common / DYNqqm_cha / eval0p
+
+ real fac_mm, summmm, sum_mm, countr
+ real sumnew, qqnmin(mz), qqnmax(mz)
+ real sumbak(mz), qqxmin(mz), qqxmax(mz) &
+ , qqnFil(mx, my, mz)
+ common / DYNqqm_rea / sumbak, qqxmin, qqxmax &
+ , qqnFil
+
+ data RetroD/.false./
+ data Set_MM/.false./
+ data logqqm/.false./
+ real FacFIk
+ integer kk
+
+ ! FacFIk=humidity_magic*max(0.8,min(1.2,(25000./dx)**0.25))
+
+ FacFIk = max(1., min(humidity_magic, 25.))
+
+ ! Conservation Constraint Boundary
+ ! ================================
+
+ if(.not. logqqm) then
+ logqqm = .true.
+ ! write(6,6) lb
+ !6 format(/,'*** DYNqqm: lb =',i3,' ***',/,' ******',/)
+ endif
+
+ ! Retro-diffusion (Before Process)
+ ! ================================
+
+ !$OMP PARALLEL do private (i,j,k, fac_mm,summmm,sum_mm,countr,sumnew)
+ do k = kk, mz
+ if(RetroD) then
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = (FIsloQ / FIslou) &
+ * FIkhmn * (specQt(i - 1, j, k) - 4. &
+ *specQt(i, j, k) + specQt(i + 1, j, k) &
+ + specQt(i, j - 1, k) + specQt(i, j + 1, k)) &
+ * dtx / dx
+ enddo
+ enddo
+ ! end do
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ specQt(i, j, k) = specQt(i, j, k) - WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = 0.
+ enddo
+ enddo
+ ! end do
+ endif
+
+ ! Mass Evaluation (Before Process)
+ ! ================================
+
+ if(eval_s == 'BAK') then
+ eval0p = eval_p
+ ! do k=1,mz
+ qqxmax(k) = 0.0
+ qqxmin(k) = 1.e20
+ do j = 1, my
+ do i = 1, mx
+ qqnFil(i, j, k) = specQt(i, j, k) * pstDYn(i, j) &
+ / (SFm_DY(i, j) * SFm_DY(i, j))
+ qqxmax(k) = max(qqxmax(k), qqnFil(i, j, k))
+ qqxmin(k) = min(qqxmin(k), qqnFil(i, j, k))
+ enddo
+ enddo
+ ! end do
+
+ if(FIBord) then
+ ! do k=1,mz
+ sumbak(k) = 0.0
+ do j = lgy, ldy
+ do i = lgx, ldx
+ sumbak(k) = sumbak(k) + qqnFil(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ if(eval_p(1:3) == 'FIL') then
+
+ ! do k=1,mz
+ do j = lgy, ldy
+ sumbak(k) = sumbak(k) + dtx &
+ * (FIkhmn * FacFIk * &
+ (specQt(lgx1, j, k) * pstDYn(lgx1, j) &
+ - specQt(lgx, j, k) * pstDYn(lgx, j) &
+ + specQt(ldx1, j, k) * pstDYn(ldx1, j) &
+ - specQt(ldx, j, k) * pstDYn(ldx, j))) / &
+ dx
+ enddo
+
+ do i = lgx, ldx
+ sumbak(k) = sumbak(k) + dtx &
+ * (FIkhmn * FacFIk * &
+ (specQt(i, lgy1, k) * pstDYn(i, lgy1) &
+ - specQt(i, lgy, k) * pstDYn(i, lgy) &
+ + specQt(i, ldy1, k) * pstDYn(i, ldy1) &
+ - specQt(i, ldy, k) * pstDYn(i, ldy))) / &
+ dx
+ enddo
+ ! end do
+ endif
+ else
+ ! do k=1,mz
+ sumbak(k) = 0.0
+ do j = 1, my
+ do i = 1, mx
+ sumbak(k) = sumbak(k) + qqnFil(i, j, k)
+ enddo
+ enddo
+ ! end do
+ endif
+
+ else if(eval_s == 'SET') then
+ ! Mass Reset (After Process)
+ ! ===========================
+ if(eval_p /= eval0p) then
+ write(6, 6010) eval_p, eval0p
+6010 format('Problem in Mass Reset, Process', a7, ' .NE. ', a6)
+ STOP
+ endif
+ ! do k=1,mz
+ qqnmax(k) = 0.0
+ qqnmin(k) = 1.e20
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = specQt(i, j, k) * pstDYn(i, j) &
+ / (SFm_DY(i, j) * SFm_DY(i, j))
+ enddo
+ enddo
+ ! end do
+#if(VQ)
+ summmm = 0.0
+#endif
+ if(FIBord) then
+ ! do k=1,mz
+ sumnew = 0.0
+ do j = lgy, ldy
+ do i = lgx, ldx
+ sumnew = WKxyz1(i, j, k) + sumnew
+ enddo
+ enddo
+ sumnew = max(eps9, sumnew)
+ countr = (ldx - lgx + 1) * (ldy - lgy + 1)
+ fac_mm = sumbak(k) / sumnew
+#if(VQ)
+ summmm = summmm + dsigm1(k) * fac_mm
+#endif
+ do j = 1, my
+ do i = 1, mx
+ specQt(i, j, k) = specQt(i, j, k) * fac_mm
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * fac_mm
+ qqnmax(k) = max(WKxyz1(i, j, k), qqnmax(k))
+ qqnmin(k) = min(WKxyz1(i, j, k), qqnmin(k))
+ enddo
+ enddo
+ sumbak(k) = sumbak(k) / countr
+ ! end do
+ else
+ ! do k=1,mz
+ sumnew = 0.0
+ do j = 1, my
+ do i = 1, mx
+ sumnew = WKxyz1(i, j, k) + sumnew
+ enddo
+ enddo
+ sumnew = max(eps9, sumnew)
+ countr = mx * my
+ fac_mm = sumbak(k) / sumnew
+#if(VQ)
+ summmm = summmm + dsigm1(k) * fac_mm
+#endif
+ do j = 1, my
+ do i = 1, mx
+ specQt(i, j, k) = specQt(i, j, k) * fac_mm
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * fac_mm
+ qqnmax(k) = max(WKxyz1(i, j, k), qqnmax(k))
+ qqnmin(k) = min(WKxyz1(i, j, k), qqnmin(k))
+ enddo
+ enddo
+ sumbak(k) = sumbak(k) / countr
+ ! end do
+ endif
+
+ ! Maximorum/Minimorum RESET (water vapor only)
+ ! ============================================
+
+ if(eval_p == 'FIL_Qv' .and. Set_MM) then
+#if(VQ)
+ sum_mm = 0.
+#endif
+ ! do k=1,mz
+ fac_mm = (qqxmax(k) - sumbak(k)) &
+ / (max(epsi, qqnmax(k) - sumbak(k)))
+ fac_mm = min((sumbak(k) - sigma(k) * 103.5 * epsq) &
+ / (sumbak(k) - qqnmin(k)), fac_mm)
+ fac_mm = max(1.0, fac_mm)
+#if(VQ)
+ sum_mm = sum_mm + dsigm1(k) * fac_mm
+#endif
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = sumbak(k) + fac_mm * (WKxyz1(i, j, k) - sumbak(k))
+ specQt(i, j, k) = WKxyz1(i, j, k) * SFm_DY(i, j) * SFm_DY(i, j) &
+ / pstDYn(i, j)
+ enddo
+ enddo
+ ! end do
+
+ ! Output of Statistics
+ ! ====================
+#if(VQ)
+ if(mod(jhurGE, 3) == 0 .and. minuGE == 0 .and. jsecGE == 0) write(24, 240)
+240 format(21x, 'RESTORE MASS ... EXTREMA')
+ write(24, 241) jdarGE, labmGE(mmarGE), iyrrGE &
+ , jhurGE, minuGE, jsecGE &
+ , summmm, sum_mm
+241 format(i3, '-', a3, '-', i4, i3, 'h', i2, ':', i2, 2f12.6)
+#endif
+ endif
+
+ ! Work Array(s) reset
+ ! ===================
+
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.
+ enddo
+ enddo
+ ! end do
+
+ else
+ write(6, 6020) eval_s
+6020 format('Problem in Mass Reset, Type ', a4)
+ STOP
+ ENDif
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+endsubroutine DYNqqm
diff --git a/MAR/code_mar/dynrho.f90 b/MAR/code_mar/dynrho.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0abc6f0e37ee5c17b8236870498a1f46b3cc4dc6
--- /dev/null
+++ b/MAR/code_mar/dynrho.f90
@@ -0,0 +1,67 @@
+subroutine dynrho
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS 16-12-2000 MAR |
+ ! | subroutine dynrho computes the Air Specific Mass |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ pstDY(mx,my) : Atmosphere Thickness [kPa] |
+ ! | tairDY(mx,my,mz): Air Temperature [K] |
+ ! | virDY(mx,my,mz): Air Loading by Water Vapor and Hydrometeors |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ rolvDY(mx,my,mz): Air Specific Mass at Sigma Levels [T/m3] |
+ ! | romiDY(mx,my,mz): Air Specific Mass in Sigma Layers [T/m3] |
+ ! | pstDY2(mx,my) : Atmosphere Thickness Squared [kPa2] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_sl
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ real sigmmz
+ ! +
+ ! +--Perfect Gas Law Relationship
+ ! + ----------------------------
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ! rolvDY(i,j,k) : Air Specific Mass at grid point (i,j,k)
+ ! 0.715 allows to include vir by 0.715=0.608/0.850
+ rolvDY(i, j, k) = (pstDYn(i, j) * sigma(k) + ptopDY) &
+ / (RDryAi * tairDY(i, j, k) * (1.0 + 0.715 * virDY(i, j, k)))
+ enddo
+ enddo
+ enddo
+ ! +
+ do k = 1, mmz1
+ do j = 1, my
+ do i = 1, mx
+ ! romiDY(i,j,k) : Air Specific Mass at grid point (i,j,k+1/2)
+ romiDY(i, j, k) = (pstDYn(i, j) * sigmid(kp1(k)) + ptopDY) &
+ / (RDryAi * 0.5 * (tairDY(i, j, k) * (1.0 + 0.715 * virDY(i, j, k)) &
+ + tairDY(i, j, kp1(k)) * (1.0 + 0.715 * virDY(i, j, kp1(k)))))
+ enddo
+ enddo
+ enddo
+ ! +
+ sigmmz = 0.500 * (1.0 + sigma(mz))
+ do j = 1, my
+ do i = 1, mx
+ romiDY(i, j, mz) = (pstDYn(i, j) * sigmmz + ptopDY) &
+ / (RDryAi * 0.50 * (tairDY(i, j, mz) + TairSL(i, j)) &
+ * (1.0 + 0.715 * virDY(i, j, mz)))
+ pstDY2(i, j) = pstDY(i, j) * pstDY(i, j)
+ enddo
+ enddo
+ return
+endsubroutine dynrho
diff --git a/MAR/code_mar/dynwww.f90 b/MAR/code_mar/dynwww.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1637135f83b4f191840f154ef4ccaca28b7edeb1
--- /dev/null
+++ b/MAR/code_mar/dynwww.f90
@@ -0,0 +1,75 @@
+#include "MAR_pp.def"
+subroutine dynwww
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS DIAGNOSTICS 06-21-2022 MAR |
+ ! | subroutine dynwww computes Vertical Wind Speed wairDY (z Coordinate) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ psigDY(i,j,k): Vertical Wind Speed (Sigma Coordinate system) |
+ ! | on Level k |
+ ! | uairDY(i,j,k): k Sigma Level Wind (x-direction) [m/s] |
+ ! | vairDY(i,j,k): k Sigma Level Wind (y-direction) [m/s] |
+ ! | gplvDY(i,j,k): k Sigma Level Geopotential [m2/s2] |
+ ! | tairDY(i,j,k): k Sigma Level Temperature [K] |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ wairDY(i,j,k)= -(R T /p) g dSigma /dt + (u dz /dx +v dz /dy) |
+ ! | [cm/s] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_wk
+ use marvec
+
+ implicit none
+
+ integer i, j, k, m
+
+ !$OMP PARALLEL do default(shared) private(i,j,k)
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, mz
+ ! +--u d(phi)/d(x)
+ ! + =============
+
+ WKxyz2(i, j,k) = &
+ fac43 * (gplvDY(ip1(i), j, k) - gplvDY(im1(i), j, k) &
+ - 0.125 * (gplvDY(ip2(i), j, k) - gplvDY(im2(i), j, k))) * dyinv3(i, j)
+
+ WKxyz1(i, j, k) = WKxyz2(i, j,k) * uairDY(i, j, k)
+
+ ! +--v d(phi)/d(y)
+ ! + =============
+ if(mmy > 1) then
+
+ WKxyz2(i, j, k) = &
+ fac43 * (gplvDY(i, jp1(j), k) - gplvDY(i, jm1(j), k) &
+ - 0.125 * (gplvDY(i, jp2(j), k) - gplvDY(i, jm2(j), k))) * dyinv3(i, j)
+
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) &
+ + WKxyz2(i, j, k) * vairDY(i, j, k)
+
+ endif
+
+ ! +--Vertical Wind Speed (cm/s)
+ ! + ==========================
+
+ wairDY(i, j, k) = -RDryAi * tairDY(i, j, k) * psigDY(i, j, k) * grvinv &
+ / (pstDY(i, j) * sigma(k) + ptopDY) * 100. &
+ +WKxyz1(i, j, k) * grvinv * 100.
+
+ WKxyz2(i, j, k) = 0.0
+ WKxyz1(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+endsubroutine dynwww
diff --git a/MAR/code_mar/filatmo.f90 b/MAR/code_mar/filatmo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..90a8ce511517451bbcb8ed8c5e7046651b7c0d55
--- /dev/null
+++ b/MAR/code_mar/filatmo.f90
@@ -0,0 +1,142 @@
+#include "MAR_pp.def"
+subroutine filatmo
+ ! +------------------------------------------------------------------------+
+ ! | MAR Filtering 14-03-2018-XF MAR |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mar_ib
+ use mardsv
+
+ implicit none
+ integer i, j, k, m
+ real min_tt_sea, min_tt_land, diff_max
+#if(AC)
+ data min_tt_sea/-80./ !degree C
+ data min_tt_land/-90./ !degree C
+#endif
+ data min_tt_sea/-70./ !degree C
+ data min_tt_land/-75./ !degree C
+ data diff_max/35./ !degree C
+
+ real :: min_tt, tt, diff, ww, w
+ real :: pk, ua, va, wa, gp, ps
+ real :: force_filtering(mx, my)
+
+ integer :: n, ii, jj, step
+
+ if(iterun <= 1) then
+ write(6, 11) min_tt_sea, min_tt_land
+11 format(' WARNING: filatmo min Temp. over sea=', f5.0, &
+ ' min Temp. over land=', f5.0)
+ else
+ force_filtering = 0
+ step = 0
+999 continue
+ !$OMP PARALLEL do default(shared) &
+ !$OMP private(i,j,k,min_tt,diff,pk,ua,va,wa,gp,ps,ww,ii,jj) &
+ !$OMP schedule(dynamic)
+ do k = mz / 3, mz
+ do i = 2, mx - 1
+ do j = 2, my - 1
+ if(isolSL(i, j) <= 2) then
+ min_tt = min_tt_sea
+ else
+ min_tt = min_tt_land
+ endif
+
+ if(isnan(uairDY(i, j, k)) .or. isnan(tairDY(i, j, k)) &
+ .or. isnan(vairDY(i, j, k)) .or. tairDY(i, j, k) < 173.15) then
+ call time_steps
+ print *, "STOP in filatmo.f: NaN on pixel(i,j,k)", i, j, k
+ print *, tairDY(i, j, k), uairDY(i, j, k), vairDY(i, j, k)
+ stop
+ endif
+
+ diff = 0
+
+ if(tairdy(i, j, k) - 273.15 < min(-30., min_tt + 30.)) then
+ diff = max(diff, abs(tairdy(i, j, k) - tairdy(i - 1, j, k)))
+ diff = max(diff, abs(tairdy(i, j, k) - tairdy(i + 1, j, k)))
+ diff = max(diff, abs(tairdy(i, j, k) - tairdy(i, j - 1, k)))
+ diff = max(diff, abs(tairdy(i, j, k) - tairdy(i, j + 1, k)))
+ endif
+
+ if(tairdy(i, j, k) - 273.15 < min_tt .or. diff > diff_max .or. &
+ isnan(pktaDY(i, j, k)) .or. &
+ force_filtering(i, j) > 0) then
+ pk = 0
+ ua = 0
+ va = 0
+ wa = 0
+ gp = 0
+ ps = 0
+ ww = 0
+ do ii = -1, 1
+ do jj = -1, 1
+ w = 1
+ if(ii == 0 .or. jj == 0) w = 2
+ if(ii == 0 .and. jj == 0) w = 0
+ if(tairdy(i + ii, j + jj, k) > tairdy(i, j, k) + 20. .and. &
+ .not. isnan(pktaDY(i + ii, j + jj, k))) then
+ pk = pk + w * pktaDY(i + ii, j + jj, k)
+ ! ua = ua + w * uairDY(i+ii, j+jj, k)
+ ! va = va + w * vairDY(i+ii, j+jj, k)
+ ! wa = wa + w * wairDY(i+ii, j+jj, k)
+ gp = gp + w * gplvDY(i + ii, j + jj, k)
+ ps = ps + w * pstDY(i + ii, j + jj)
+ ww = ww + w
+ else
+ force_filtering(i + ii, j + jj) = 1
+ endif
+ enddo
+ enddo
+
+ if(ww > 2) then
+ pktaDY(i, j, k) = pk / ww
+ ! uairDY(i, j, k) = ua / ww
+ ! vairDY(i, j, k) = va / ww
+ ! wairDY(i, j, k) = wa / ww
+ gplvDY(i, j, k) = gp / ww
+ pstDY(i, j) = ps / ww
+ tt = -273.15 + pktaDY(i, j, k) * ((pstDY(i, j) * sigma(k) + ptopDY)**cap)
+ !$OMP CRITICAL
+ write(6, 12) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, &
+ i, j, k, tairdy(i, j, k) - 273.15, tt
+12 format('ERROR filatmo', &
+ i5, 4i3, ' for (', i3, ','i3, ',', i2, ')', f6.0, '=>', f6.0)
+ write(6, *)
+ !$OMP END CRITICAL
+ tairdy(i, j, k) = pktaDY(i, j, k) * ((pstDY(i, j) * sigma(k) + ptopDY)**cap)
+ force_filtering(i, j) = 1
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ do i = 2, mx - 1
+ do j = 2, my - 1
+ if(force_filtering(i, j) > 0 .and. step <= 1) then
+ step = step + 1
+ goto 999
+ endif
+ enddo
+ enddo
+
+ endif
+
+endsubroutine filatmo
diff --git a/MAR/code_mar/grdgeo.f90 b/MAR/code_mar/grdgeo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ffbdee0aae265543f381f5aaf68bd83b250c38fb
--- /dev/null
+++ b/MAR/code_mar/grdgeo.f90
@@ -0,0 +1,379 @@
+#include "MAR_pp.def"
+subroutine grdgeo
+ ! +------------------------------------------------------------------------+
+ ! | MAR GRID Tue 14-04-2021 MAR |
+ ! | subroutine grdgeo computes the Latitudes, Longitudes and |
+ ! | the Time Zone of each Grid Point |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: abs(maptyp)=0: Polar Stereogr. Project. (ALL LATITUDES) |
+ ! | ^^^^^ 1: Oblique Stereogr. Project. (ALL LATITUDES |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ imez,jmez : Indices of the MAR Domain Center |
+ ! | GEddxx : (2-D): x-Axis Direction |
+ ! | (3-D): South-North Direction along |
+ ! | 90E, 180E, 270E or 360E Meridians |
+ ! | GElat0 : Latitude of (0,0) in MAR (deg) |
+ ! | GElon0 : Longitude of (0,0) in MAR (deg) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ GElatr(mx,my): Latitude of the (x,y) MAR coordinate (rad) |
+ ! | GElonh(mx,my): Longitude of the (x,y) MAR coordinate (h) |
+ ! | itizGE(mx,my): Time Zone |
+ ! | fcorDY(mx,my): Coriolis Parameter (may be variable) |
+ ! | |
+ ! | MODIF. 3 Nov 2009 : Map Scaling Factor SFm_DY computed only |
+ ! | ^^^^^ for a domain which is North/South Pole |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ integer i1_gg, i2_gg, id10, jd10
+ real GElon, GElat, RadLat, clat_s
+ real argrot, cosrot, sinrot
+ real xxmar0, yymar0, x0, y0
+ real ddista, xdista, ydista
+ real lon2, lat2, lon1, lat1, distance, d1, d2
+
+ ! +--GEOGRAPHIC Coordinates
+ ! + ======================
+ if(.not. geoNST) then
+ ! +--1-D and 2-D Cases
+ ! + -----------------
+ if(mmy == 1) then
+ argrot = (GEddxx - 90.0) * degrad
+ cosrot = cos(argrot)
+ sinrot = sin(argrot)
+ do j = 1, my
+ do i = 1, mx
+ xxmar0 = cosrot * (i - imez) * dx + sinrot * (j - jmez) * dx
+ yymar0 = cosrot * (j - jmez) * dx - sinrot * (i - imez) * dx
+ ! + ******
+ call grdstr(xxmar0, yymar0, GElon0, GElat0, GElon, GElat, GEtrue)
+ ! + ******
+ GElatr(i, j) = GElat
+ GElonh(i, j) = GElon
+ enddo
+ enddo
+ else
+ ! +--3-D Cases
+ ! + ---------
+
+ ! +- ANTARCTICA (Polar Stereographic Projection is assumed)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(maptyp == 0) then
+ call stereosouth_inverse(GElon0, GElat0, GEddxx, x0, y0)
+ xxkm = xxkm + x0
+ yykm = yykm + y0
+ do j = 1, my
+ do i = 1, mx
+ xxmar0 = (i - imez) * dx / 1000.+x0
+ yymar0 = (j - jmez) * dy / 1000.+y0
+ ! + ***********
+ call StereoSouth(xxmar0, yymar0, GEddxx, GElon, GElat, GElat0)
+ ! + ***********
+ ! Conversion: degrees->hour
+ GElonh(i, j) = GElon / 15.
+ ! Conversion: rad ->degrees
+ GElatr(i, j) = GElat * degrad
+ enddo
+ enddo
+ endif
+
+#if(PP)
+ if(maptyp == 0) then
+ ! transformation stereographic coordinates (center = South Pole)
+ ! -> spherical coordinates
+ ddista = earthr * 2.0 * tan((45.0 + GElat0 * 0.50) * degrad)
+ xdista = ddista * cos((90.0 - GElon0) * degrad)
+ ydista = ddista * sin((90.0 - GElon0) * degrad)
+ do j = 1, my
+ do i = 1, mx
+ if(abs(GEddxx - 90.0) < epsi) then
+ xxmar0 = (i - imez) * dx
+ yymar0 = (j - jmez) * dy
+ endif
+ if(abs(GEddxx) < epsi) then
+ xxmar0 = (j - jmez) * dy
+ yymar0 = -(i - imez) * dx
+ endif
+ if(abs(GEddxx - 270.0) < epsi) then
+ xxmar0 = -(i - imez) * dx
+ yymar0 = -(j - jmez) * dy
+ endif
+ if(abs(GEddxx - 180.0) < epsi) then
+ xxmar0 = -(j - jmez) * dy
+ yymar0 = (i - imez) * dx
+ endif
+
+ xxmar0 = xxmar0 + xdista
+ yymar0 = yymar0 + ydista
+
+ ddista = sqrt(xxmar0 * xxmar0 + yymar0 * yymar0)
+ GElatr(i, j) = -0.5 * pi + 2.*atan(ddista * 0.5 / earthr)
+ if(abs(xxmar0) > zero) then
+ GElonh(i, j) = atan(yymar0 / xxmar0)
+ if(xxmar0 < zero) then
+ GElonh(i, j) = GElonh(i, j) + pi
+ endif
+ GElonh(i, j) = 0.50 * pi - GElonh(i, j)
+ if(GElonh(i, j) > pi) then
+ GElonh(i, j) = -2.00 * pi + GElonh(i, j)
+ endif
+ if(GElonh(i, j) < -pi) then
+ GElonh(i, j) = 2.00 * pi + GElonh(i, j)
+ endif
+ else
+ if(yymar0 > zero) then
+ GElonh(i, j) = 0.00
+ else
+ GElonh(i, j) = pi
+ endif
+ endif
+ ! Conversion : radian -> Hour
+ GElonh(i, j) = GElonh(i, j) / hourad
+ enddo
+ enddo
+ endif
+#endif
+ ! +- OTHERS (Oblique Stereographic Projection is assumed)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(abs(maptyp) == 1) then
+ do j = 1, my
+ do i = 1, mx
+ argrot = (GEddxx - 90.0) * degrad
+ cosrot = cos(argrot)
+ sinrot = sin(argrot)
+ xxmar0 = cosrot * (i - imez) * dx + sinrot * (j - jmez) * dy
+ yymar0 = cosrot * (j - jmez) * dy - sinrot * (i - imez) * dx
+ ! + ***********
+ call grdstr(xxmar0, yymar0, GElon0, GElat0, GElon, GElat, GEtrue)
+ ! + ***********
+ GElatr(i, j) = GElat
+ GElonh(i, j) = GElon
+ enddo
+ enddo
+ endif
+ endif
+ endif
+
+ do i = 1, mx
+ lon2 = GElonh(i, jmez) * 15.
+ lat2 = GElatr(i, jmez) / degrad
+ lon1 = GElonh(imez, jmez) * 15.
+ lat1 = GElatr(imez, jmez) / degrad
+ xxkm2(i) = distance(lon2, lat2, lon1, lat1)
+ if(i <= imez) xxkm2(i) = -1.*xxkm2(i)
+ enddo
+
+ do j = 1, my
+ lon2 = GElonh(imez, j) * 15.
+ lat2 = GElatr(imez, j) / degrad
+ lon1 = GElonh(imez, jmez) * 15.
+ lat1 = GElatr(imez, jmez) / degrad
+ yykm2(j) = distance(lon2, lat2, lon1, lat1)
+ if(j <= jmez) yykm2(j) = -1.*yykm2(j)
+ enddo
+
+ do i = 2, mx - 1
+ do j = 2, my - 1
+ d1 = 0; d2 = 0
+ do k = -1, 1, 2
+ lon1 = GElonh(i, j) * 15.
+ lon2 = GElonh(i + k, j) * 15.
+ lat1 = GElatr(i, j) / degrad
+ lat2 = GElatr(i + k, j) / degrad
+ d1 = d1 + distance(lon2, lat2, lon1, lat1) / 2.
+ enddo
+ do k = -1, 1, 2
+ lon1 = GElonh(i, j) * 15.
+ lon2 = GElonh(i, j + k) * 15.
+ lat1 = GElatr(i, j) / degrad
+ lat2 = GElatr(i, j + k) / degrad
+ d2 = d2 + distance(lon2, lat2, lon1, lat1) / 2.
+ enddo
+ area(i, j) = d1 * d2
+ d1 = 0; d2 = 0
+ do k = -1, 1, 2
+ lon1 = GElonh(i, j) * 15.
+ lon2 = GElonh(i + k, j) * 15.
+ lat1 = GElatr(i, j) / degrad
+ lat2 = GElatr(i + k, j) / degrad
+ d1 = d1 + distance(lon2, lat2, lon1, lat1) / 2.
+ enddo
+ do k = -1, 1, 2
+ lon1 = GElonh(i, j) * 15.
+ lon2 = GElonh(i, j + k) * 15.
+ lat1 = GElatr(i, j) / degrad
+ lat2 = GElatr(i, j + k) / degrad
+ d2 = d2 + distance(lon2, lat2, lon1, lat1) / 2.
+ enddo
+ dx3(i, j) = d1 * 1000.
+ dy3(i, j) = d2 * 1000.
+ dxy3(i, j) = (dx3(i, j) + dy3(i, j)) / 2.
+ dxinv3(i, j) = 1./(dx3(i, j) * 2.)
+ dyinv3(i, j) = 1./(dy3(i, j) * 2.)
+ enddo
+ enddo
+
+ do i = 1, mx
+ area(i, 1) = area(i, 2)
+ area(i, my) = area(i, my - 1)
+ dx3(i, 1) = dx3(i, 2)
+ dx3(i, my) = dx3(i, my - 1)
+ dy3(i, 1) = dy3(i, 2)
+ dy3(i, my) = dy3(i, my - 1)
+ enddo
+
+ do j = 1, my
+ area(1, j) = area(2, j)
+ area(mx, j) = area(mx - 1, j)
+ dx3(1, j) = dx3(2, j)
+ dx3(mx, j) = dx3(mx - 1, j)
+ dy3(1, j) = dy3(2, j)
+ dy3(mx, j) = dy3(mx - 1, j)
+ enddo
+
+ ! +--Sine, Cosine of Latitude
+ ! + ========================
+ do j = 1, my
+ do i = 1, mx
+ clatGE(i, j) = cos(GElatr(i, j))
+ slatGE(i, j) = sin(GElatr(i, j))
+ enddo
+ enddo
+
+ ! +--Scaling Map Factor
+ ! + ==================
+ if(abs(GElat0) >= 90.-epsi) then
+ clat_s = 1.+sin((90.-GEtrue) * degrad)
+ do j = 1, my
+ do i = 1, mx
+ SFm_DY(i, j) = clat_s / (1.+abs(slatGE(i, j)))
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ SFm_DY(i, j) = 1.0
+ enddo
+ enddo
+ endif
+
+ ! +--Numerical Equator
+ ! + ~~~~~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ if(abs(GElatr(i, j)) < epsi) then
+ RadLat = epsi
+ slatGE(i, j) = sin(RadLat)
+ clatGE(i, j) = cos(RadLat)
+ endif
+
+ ! +--Numerical North Pole
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ if(GElatr(i, j) > demi * pi - epsi) then
+ RadLat = demi * pi - epsi
+ !XF slatGE(i,j) = sin(RadLat )
+ !XF clatGE(i,j) = cos(RadLat )
+ slatGE(i, j) = 1.
+ clatGE(i, j) = 0.
+ endif
+
+ ! +--Numerical South Pole
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ if(GElatr(i, j) < epsi - demi * pi) then
+ RadLat = epsi - demi * pi
+ !XF slatGE(i,j) = sin(RadLat )
+ !XF clatGE(i,j) = cos(RadLat )
+ slatGE(i, j) = -1.
+ clatGE(i, j) = 0.
+ endif
+ enddo
+ enddo
+
+ ! +--Coriolis Parameter
+ ! + ==================
+ do j = 1, my
+ do i = 1, mx
+ fcorDY(i, j) = 2.0 * earthv * sin(GElatr(i, j))
+#if(CC)
+ ! fcorDY: Coriolis Parameter
+ fcorDY(i, j) = 2.0 * earthv * sin(GElatr(imez, jmez))
+#endif
+ enddo
+ enddo
+
+ ! +--Time Zone
+ ! + =========
+ do j = 1, my
+ do i = 1, mx
+ itizGE(i, j) = GElonh(i, j)
+ if(itizGE(i, j) > 12) itizGE(i, j) = itizGE(i, j) - 24
+ if(itizGE(i, j) < -12) itizGE(i, j) = itizGE(i, j) + 24
+ enddo
+ enddo
+
+ ! +--OUTPUT
+ ! + ======
+ i1_gg = imez - 50
+ i2_gg = imez + 50
+ i1_gg = max(i1_gg, 1)
+ i2_gg = min(i2_gg, mx)
+ id10 = 1 + min(mx - 1, 10)
+ jd10 = 1 + min(my - 1, 10)
+
+ write(4, 990)(i, i=i1_gg, i2_gg, id10)
+990 format(/, ' LATITUDES / LONGITUDES / TOPOGRAPHY: x -> y ^ ', &
+ /, ' ===================================', /, 9x, 13i9)
+ do j = my, 1, -jd10
+ do i = i1_gg, i2_gg, id10
+ write(4, 991) j,(GElatr(i, j) / degrad)
+991 format(i9, 11f9.3)
+ write(4, 992)(GElonh(i, j) * 1.5d+1)
+992 format(9x, 11f9.3)
+ write(4, 993)(sh(i, j) * 1.0d-3)
+993 format(9x, 11f9.3)
+ write(4, 994)(itizGE(i, j))
+994 format(9x, 11i9)
+ write(4, 995)(fcorDY(i, j))
+995 format(9x, 11f9.6)
+ enddo
+ enddo
+
+ return
+endsubroutine grdgeo
+
+function distance(lon2, lat2, lon1, lat1)
+ use marphy
+ implicit none
+
+ real, parameter :: R = 6378.1370
+ real :: lon1, lat1
+ real :: lon2, lat2, distance
+ real :: dlat, dlon, a, c
+
+ lat2 = lat2 * degrad
+ lon2 = lon2 * degrad
+ lat1 = lat1 * degrad
+ lon1 = lon1 * degrad
+
+ dlat = (lat2 - lat1)
+ dlon = (lon2 - lon1)
+ a = sin(dLat / 2.) * sin(dLat / 2.) &
+ + cos(lat1) * cos(lat2) * sin(dLon / 2.) * sin(dLon / 2.)
+ c = 2.*atan2(sqrt(a), sqrt(1.-a))
+ distance = max(0.0, R * c)
+endfunction distance
diff --git a/MAR/code_mar/grdmar.f90 b/MAR/code_mar/grdmar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..39c590b883d888dc215f25135368ff8ef8b1991c
--- /dev/null
+++ b/MAR/code_mar/grdmar.f90
@@ -0,0 +1,414 @@
+#include "MAR_pp.def"
+subroutine grdmar
+ ! +------------------------------------------------------------------------+
+ ! | MAR GRID 20-02-2021 MAR |
+ ! | subroutine grdmar is used to initialize the grid parameters |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ sigma(mz) : Independant Variable on Levels |
+ ! | FIslot : Implicit Filter Parameter |
+ ! | (Slow Dynamics / Temperature) |
+ ! | FIslou : ... (Slow Dynamics / Wind Speed) |
+ ! | FIslop : ... (Slow Dynamics / Pressure) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ xxkm(mx) : Distance along the x-axis (km) |
+ ! | yykm(my) : Distance along the y-axis (km) |
+ ! | |
+ ! | sigmid(mzz): Independant Variable between Levels (i.e.k-1/2)|
+ ! | dsigm1(mz ): Difference d(sigma)|k |
+ ! | qsigm1(mz ): 1 / [Difference d(sigma)|k ] |
+ ! | dsigm2(mz ): Difference 2d(sigma)|k |
+ ! | qsigm2(mz ): 1 / [Difference 2d(sigma)|k ] |
+ ! | dsig_1(mzz): Difference d(sigma)|k+1/2 |
+ ! | qsig_1(mzz): 1 / [Difference d(sigma)|k+1/2] |
+ ! | dsig_2(mzz): Difference 2d(sigma)|k+1/2 |
+ ! | |
+ ! | Ray_UB(mzabso) : Top Absorbing Layer Contribution to |
+ ! | Rayleigh Friction (-/s) |
+ ! | |
+ ! | TUspon(mzabso) : Top Absorbing Layer Contribution to |
+ ! | Horizontal Diffusion Coefficient (m2/s) |
+ ! | |
+ ! | FIspon(mzabso) : Top Absorbing Layer Contribution |
+ ! | to Implicit Filter Parameter |
+ ! | FIk_st(mz): Implicit Filter Parameter |
+ ! | (Slow Dynamics / Temperature) |
+ ! | FIk_su(mz): ...(Slow Dynamics / Wind Speed) |
+ ! | FIfstu, FIk_fu(mz): ...(Fast Dynamics / Wind Speed) |
+ ! | FIfstu, FIk_fp(mz): ...(Fast Dynamics / Pressure,Velocity) |
+ ! | |
+ ! | n6mxLB, n7mxLB : Effective Length of Lateral Sponge (x-Axe) |
+ ! | n6myLB, n7myLB : Effective Length of Lateral Sponge (y-Axe) |
+ ! | |
+ ! | im1(mx),2,..: max(i-1, 1), max(i-2, 1), etc... |
+ ! | ip1(mx),2,..: min(i+1,mx), min(i+2,mx), etc... |
+ ! | |
+ ! | jm1(my),2,..: max(j-1, 1), max(j-2, 1), etc... |
+ ! | jp1(my),2,..: min(j+1,my), min(j+2,my), etc... |
+ ! | |
+ ! | km1(mz),2,..: max(k-1, 1), max(k-2, 1), etc... |
+ ! | kp1(mz),2,..: min(k+1,mz), min(k+2,mz), etc... |
+ ! | |
+ ! | CUspxh(mx) : Cubic Spline Auxiliary Variable (x Direction) |
+ ! | CUspxb(mx) : idem |
+ ! | CUspyh(mx) : Cubic Spline Auxiliary Variable (y Direction) |
+ ! | CUspyb(mx) : idem |
+ ! | CUspzh(mx) : Cubic Spline Auxiliary Variable (z Direction) |
+ ! | CUspzb(mx) : idem |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_cu
+ use mar_lb
+ use mar_ub
+ use mar_tu
+ use mar_fi
+ use mar_io
+#if(NH)
+ use mar_nh
+#endif
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer i, j, k, m
+ integer im10, ip10, im20, ip20
+ integer jm10, jp10, jm20, jp20
+ integer km10, kp10, km20, mzabs
+ real FIabs
+ ! +
+ ! +
+ ! +--DATA
+ ! + ====
+ ! +
+ logical DFspon
+ data DFspon/.true./
+#if(KS)
+ DFspon = .false.
+#endif
+ ! +
+ ! +--Entry Checking Point
+ ! + ====================
+ ! +
+ if(IO_loc >= 2) write(21, 999)
+999 format(//, ' --- Initialisation / grdmar ---')
+ ! +
+ ! +
+ ! +--Auxiliary Horizontal Independant Variables
+ ! + ==========================================
+ ! +
+ mmx = mx
+ mmx1 = mx1
+ mmx1 = max(1, mmx1)
+ mmx2 = mx - 2
+ mmx2 = max(1, mmx2)
+ mmx3 = mx - 3
+ mmx3 = max(1, mmx3)
+ mmx4 = mx - 4
+ mmx4 = max(1, mmx4)
+ mmx5 = mx - 5
+ mmx5 = max(1, mmx5)
+ mmx6 = mx - 6
+ mmx6 = max(1, mmx6)
+ m0x2 = 2
+ m0x2 = min(mx, m0x2)
+ m0x3 = 3
+ m0x3 = min(mx, m0x3)
+ m0x4 = 4
+ m0x4 = min(mx, m0x4)
+ m0x5 = 5
+ m0x5 = min(mx, m0x5)
+ m0x6 = 6
+ m0x6 = min(mx, m0x6)
+ ! +
+ mmy = my
+ mmy1 = my1
+ mmy1 = max(1, mmy1)
+ mmy2 = my - 2
+ mmy2 = max(1, mmy2)
+ mmy3 = my - 3
+ mmy3 = max(1, mmy3)
+ mmy4 = my - 4
+ mmy4 = max(1, mmy4)
+ mmy5 = my - 5
+ mmy5 = max(1, mmy5)
+ mmy6 = my - 6
+ mmy6 = max(1, mmy6)
+ m0y2 = 2
+ m0y2 = min(my, m0y2)
+ m0y3 = 3
+ m0y3 = min(my, m0y3)
+ m0y4 = 4
+ m0y4 = min(my, m0y4)
+ m0y5 = 5
+ m0y5 = min(my, m0y5)
+ m0y6 = 6
+ m0y6 = min(my, m0y6)
+ ! +
+ mmz = mz
+ mmz1 = mz1
+ mmz1 = max(1, mmz1)
+ mmz2 = mz - 2
+ mmz2 = max(1, mmz2)
+ ! +
+ dx2 = dx * 2.0
+ dy2 = dy * 2.0
+ ! +
+ if(mmx > 1) then
+ ! +
+ dtx = dt / dx
+ dty = dt / dy
+ ! +
+ dxinv = 1.0 / dx
+ dyinv = 1.0 / dy
+ dxinv2 = 1.0 / dx2
+ dyinv2 = 1.0 / dy2
+ ! +
+ do i = 1, mx
+ ! xxkm : in km
+ xxkm(i) = (i - imez) * dx / 1000.
+ enddo
+ ! +
+ do j = 1, my
+ ! yykm : in kms
+ yykm(j) = (j - jmez) * dy / 1000.
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--4th Order Centered Difference Parameter
+ ! + ---------------------------------------
+ ! +
+ fac43 = 4.0 / 3.0
+ ! +
+ ! +
+ ! +--Effective Length of the Lateral Sponge
+ ! + --------------------------------------
+ ! +
+ if(mmx == 1) then
+ n40xLB = 1
+ n50xLB = 1
+ n5mxLB = 1
+ n6mxLB = 0
+ n7mxLB = 1
+ n40yLB = 1
+ n50yLB = 1
+ n5myLB = 1
+ n6myLB = 0
+ n7myLB = 1
+ ! +
+ else
+ n40xLB = mx - n6 + 2
+ n50xLB = mx - n6 + 1
+ n5mxLB = n6 - 1
+ n6mxLB = n6
+ n7mxLB = n7
+ ! +
+ if(mmy == 1) then
+ n40yLB = 1
+ n50yLB = 1
+ n5myLB = 1
+ n6myLB = 0
+ n7myLB = 1
+ else
+ n40yLB = my - n6 + 2
+ n50yLB = my - n6 + 1
+ n5myLB = n6 - 1
+ n6myLB = n6
+ n7myLB = n7
+ endif
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Boundaries Masks
+ ! + ----------------
+ ! +
+ do i = 1, mx
+ im10 = i - 1
+ ip10 = i + 1
+ im1(i) = max(im10, 1)
+ ip1(i) = min(ip10, mx)
+ im20 = i - 2
+ ip20 = i + 2
+ im2(i) = max(im20, 1)
+ ip2(i) = min(ip20, mx)
+ enddo
+ ! +
+ do j = 1, my
+ jm10 = j - 1
+ jp10 = j + 1
+ jm1(j) = max(jm10, 1)
+ jp1(j) = min(jp10, my)
+ jm20 = j - 2
+ jp20 = j + 2
+ jm2(j) = max(jm20, 1)
+ jp2(j) = min(jp20, my)
+ enddo
+ ! +
+ ! +
+ ! +--Auxiliary Vertical Independant Variables
+ ! + ==========================================
+ ! +
+ ! +
+ ! +--Boundaries Masks
+ ! + ----------------
+ ! +
+ do k = 1, mz
+ km10 = k - 1
+ kp10 = k + 1
+ km1(k) = max(km10, 1)
+ kp1(k) = min(kp10, mz)
+ km20 = k - 2
+ km2(k) = max(km20, 1)
+ enddo
+ ! +
+ ! +
+ ! +--Discretisation
+ ! + --------------
+ ! +
+ dsig_1(0) = sigma(1)
+ dsig_1(1) = sigma(kp1(1)) - sigma(1)
+ dsig_2(1) = sigma(kp1(1))
+ sigmid(1) = 0.0
+ sigmid(mzz) = 1.0
+ ! +
+ do k = kp1(1), mmz1
+ dsig_1(k) = sigma(kp1(k)) - sigma(k)
+ dsig_2(k) = sigma(kp1(k)) - sigma(km1(k))
+ sigmid(k) = (sigma(k) + sigma(km1(k))) / 2.0
+ dsigm1(km1(k)) = sigmid(k) - sigmid(km1(k))
+ dsigm2(km1(k)) = sigmid(k) - sigmid(km2(k))
+ enddo
+ ! +
+ ! +--The lowest layer of the model is assumed to be a constant flux layer
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dsig_1(mz) = 1.0 - sigma(mz)
+ dsig_2(mz) = sigma(mz) - sigma(km1(mz))
+ sigmid(mz) = 0.50 * (sigma(mz) + sigma(km1(mz)))
+ dsigm1(km1(mz)) = sigmid(mz) - sigmid(km1(mz))
+ dsigm2(km1(mz)) = sigmid(mz) - sigmid(km2(mz))
+ ! +
+ dsig_1(mzz) = dsig_1(mz)
+ dsig_2(mzz) = 2.00 * dsig_1(mzz)
+ dsigm1(mz) = 1.00 - sigmid(mz)
+ dsigm2(mz) = 1.00 - sigmid(km1(mz))
+ ! +
+ do k = 0, mzz
+ qsig_1(k) = 1.00 / dsig_1(k)
+ enddo
+ ! +
+ do k = 1, mz
+ qsigm1(k) = 1.00 / dsigm1(k)
+ qsigm2(k) = 1.00 / dsigm2(k)
+ enddo
+ ! +
+ ! +
+ ! +--Filter Parameter Initialisation (rapidly propagating Waves Dynamics)
+ ! + =======================================================================
+ ! +
+ !XF
+ ! FIslou=max(FIslou,0.008) ! higher is, smoother the wind is
+ ! FIslop=max(FIslop,0.008)
+ ! FIslot=max(FIslot,0.008) ! higher is, colder MAR is
+ FIslot = 0.007
+ FIfstu = FIslou / (ntFast + 1)
+ FIfstp = FIslop / (ntFast + 1)
+ ! +
+ do k = 1, mz
+ FIk_st(k) = FIslot / max(0.1, sigma(k))
+ FIk_su(k) = FIslou / max(0.1, sigma(k))
+ FIk_fu(k) = FIfstu / max(0.1, sigma(k))
+ FIk_fp(k) = FIfstp / max(0.1, sigma(k))
+ enddo
+ ! +
+ ! +
+ ! +--Top Absorbing Layer Initialisation
+ ! + ==================================
+ ! +
+ FIabs = TUkhmx * 4.0 * dtfast / (dx * dx)
+ ! +
+ if(mz > 1) then
+ mzabs = mzabso + 1
+ mzabs = min(mz, mzabs)
+ if(DFspon) then
+ do k = 1, mzabso
+ FIspon(k) = FIabs * (sigma(mzabs) - sigma(k)) &
+ / (sigma(mzabs) - sigma(1))
+ FIk_st(k) = FIk_st(k) + FIspon(k) * dt / dtfast
+ FIk_su(k) = FIk_su(k) + FIspon(k) * dt / dtfast
+ FIk_fu(k) = FIk_fu(k) + FIspon(k)
+ FIk_fp(k) = FIk_fp(k) + FIspon(k)
+ TUspon(k) = zero
+ enddo
+ else
+ do k = 1, mzabso
+ FIspon(k) = zero
+ TUspon(k) = TUkhmx * (sigma(mzabs) - sigma(k)) &
+ / (sigma(mzabs) - sigma(1))
+ enddo
+ endif
+ endif
+
+ ! +--Rayleigh Friction (Ref. ARPS 4.0 User's Guide, para 6.4.3 p.152)
+ ! + =================
+ do k = 1, mzabso
+ Ray_UB(k) = 0.5 * (1.-cos(pi * (sigma(mzabso) - sigma(k)) &
+ / (sigma(mzabso) - sigma(1)))) / (1.5 * dt)
+#if(rf)
+ Ray_UB(k) = (sigma(mzabso) - sigma(k)) / &
+ (sigma(mzabso) - sigma(1)) / (10.0 * dt)
+#endif
+ enddo
+
+ ! +--Cubic Spline Initialisation
+ ! + ===========================
+ ! +
+ ! + 1) x - Direction
+ ! + ----------------
+ CUspxh(1) = 0.0
+ CUspxh(mx) = 0.0
+ CUspxb(1) = 0.0
+ CUspxb(mx) = 0.0
+ do i = ip11, mx1
+ CUspxh(i) = CUspxb(im1(i)) + 4.0
+ CUspxb(i) = -1.0 / CUspxh(i)
+ enddo
+ ! +
+ ! + 2) y - Direction
+ ! + ----------------
+ CUspyh(1) = 0.0
+ CUspyh(my) = 0.0
+ CUspyb(1) = 0.0
+ CUspyb(my) = 0.0
+ if(mmy > 1) then
+ do j = jp11, my1
+ CUspyh(j) = CUspyb(jm1(j)) + 4.0
+ CUspyb(j) = -1.0 / CUspyh(j)
+ enddo
+ endif
+ ! +
+ ! + 3) Sigma - Direction (to be used in routine DYNadv_cubv)
+ ! + --------------------------------------------------------
+#if(ZU)
+ CUspzh(1) = dsig_1(1) / (dsig_1(1) + sigma(1))
+ CUspzh(mz) = dsig_1(mz) / (dsig_1(mz) + dsig_1(mmz1))
+ CUspzb(1) = sigma(1) / (dsig_1(1) + sigma(1))
+ CUspzb(mz) = dsig_1(mmz1) / (dsig_1(mz) + dsig_1(mmz1))
+ do k = kp1(1), mmz1
+ CUspzh(k) = dsig_1(k) / (dsig_1(k) + dsig_1(k - 1))
+ CUspzb(k) = dsig_1(k - 1) / (dsig_1(k) + dsig_1(k - 1))
+ enddo
+#endif
+ ! +
+ return
+endsubroutine grdmar
diff --git a/MAR/code_mar/grdsig.f90 b/MAR/code_mar/grdsig.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fa8a6629353a7c0b639b97d237d919b85e4d670c
--- /dev/null
+++ b/MAR/code_mar/grdsig.f90
@@ -0,0 +1,234 @@
+#include "MAR_pp.def"
+subroutine grdsig(zmin, aavu, bbvu, ccvu, vertic)
+ ! +------------------------------------------------------------------------+
+ ! | MAR GRID 15-02-2008 MAR |
+ ! | subroutine grdsig is used to initialize the vertical grid |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: zmin : Height above Surface / 1st Sigma Level (m) |
+ ! | ^^^^^ aavu,bbvu,ccvu : Vertical Discretization Parameters |
+ ! | vertic : Logical Variable caracteris.vertic.discris.|
+ ! | |
+ ! | DATA: sigpar(10) : Parish Model Vertical Discretisation |
+ ! | ^^^^^ |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ Variable which is initialized is: |
+ ! | sigma(mz): Independant Variable (Normalized Pressure) |
+ ! | |
+ ! | ASSUMPTION: sigma is calculated from initial level height amsl |
+ ! | ^^^^^^^^^^^ assumig that T(msl) = SST |
+ ! | dT/dz = -0.0065 K/m |
+ ! | p_s = 100 hPa |
+ ! | |
+ ! | # OPTIONS: #SA Regular Vertical Discretisation |
+ ! | # ^^^^^^^^ #PA Parish Model Vertical Discretisation |
+ ! | # #ll LMDZ Model Vertical Discretisation (L. Li) |
+ ! | # #HE NORLAM Vertical Discretisation (G. Heineman) |
+ ! | # #L1 Alternate Vertical Discretisation (when very fine) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+ use marsnd
+ use mar_dy
+ use mar_tu
+ use mar_sl
+ use mar_io
+ use mar_wk
+
+ implicit none
+
+ logical, intent(in) :: vertic
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ integer lsf, lvg, kk, km, kn, k1
+ real ga0, gaz, zmin, dzz, rz, rzb, zzo, sh_min
+ real ps_sig, vu, aavu, bbvu, ccvu, ps_max, pstar0
+#if(HE)
+ real sighei(29)
+#endif
+#if(lm)
+ real siglmd(11)
+#endif
+#if(PA)
+ real sigpar(10), sigp11, sigp12(11:12), sigp13(10:13)
+#endif
+
+ ! +--DATA
+ ! + ====
+ ! data ps_sig/101.3e0/
+ data ps_sig/100.0e0/
+#if(HE)
+ ! sighei: DNMI model Vertical Discretisat. (Heinemann 1996)
+ data sighei/0.10015, 0.19077, 0.27276, 0.34695, 0.41409, &
+ 0.47483, 0.52979, 0.57952, 0.62452, 0.66524, 0.70208, &
+ 0.73542, 0.76558, 0.79288, 0.81757, 0.83992, 0.86014, &
+ 0.87844, 0.89499, 0.90997, 0.92352, 0.93579, 0.94688, &
+ 0.95692, 0.96601, 0.97423, 0.98167, 0.98840, 0.99111/
+#endif
+#if(lm)
+ ! siglmd: Vertical Discretisation of LMDZ Model
+ ! (Laurent LI, personal communication, 5 dec. 2000)
+ data siglmd/0.014767, 0.071835, 0.150135, 0.270661, 0.410669, &
+ 0.565832, 0.708390, 0.829996, 0.913837, 0.966484, &
+ 0.990723/
+#endif
+#if(PA)
+ ! sigpar: Vertical Discretisation of Parish Model
+ ! (Bromwich, Du and Parish 1994 MWR 122 No 7 p.1418)
+ data sigpar/0.100, 0.350, 0.600, 0.800, 0.900, &
+ 0.930, 0.950, 0.970, 0.985, 0.996/
+ ! sigp1x: Vertical Discretisation of Parish Model (modified)
+ data sigp11/0.998/
+ data(sigp12(k), k=11, 12) / 0.998, 0.999 /
+ data(sigp13(k), k=10, 13) / 0.990, 0.996, 0.998, 0.999 /
+#endif
+ data lsf/1/
+ ! ga0 : Standard Atmospheric Lapse Rate
+ data ga0/0.0065e0/
+ ! lvg : set to 1 if |Vg(sounding)| .ne. 0 anywhere
+ lvg = 0
+
+ ! +--Entry Checking Point
+ ! + ====================
+ if(IO_loc >= 2) write(21, 999)
+999 format(//, ' --- Initialisation / grdsig ---')
+
+ ! +--Temperature Vertical Profile
+ ! + ============================
+ gaz = ga0
+
+ if(IO_loc >= 2) write(21, 1) gaz, sst_SL, ps_sig, gravit, RDryAi
+1 format(/, ' dT/dz =', f8.5, ' K/m', &
+ /, ' SST =', f8.2, ' K', &
+ /, ' ps_sig =', f8.2, ' kPa', &
+ /, ' gravit =', f8.2, ' m/s2', &
+ /, ' RDryAi =', f8.2, ' J/kg/K')
+
+ ! +--Sigma Levels
+ ! + ============
+
+ ! +- 1) Coarse Resolution of the Surface Layer
+ ! + -----------------------------------------
+ if(.not. vertic) then
+ ! Reference : E. Richard, these, 1991, p.29
+ ! aa = 0.5
+ ! bb = 1.5
+ ! cc =-1.0
+ vu = 0.0
+ do k = 1, mz
+ vu = vu + 1.0 / dble(mzz)
+ sigma(k) = aavu * vu + bbvu * vu * vu + ccvu * vu * vu * vu
+#if(HE)
+ ! +- Vertical Discretisation of NORLAM
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ sigma(k) = sighei(k)
+#endif
+ enddo
+#if(lm)
+ do k = 1, 11
+ sigma(k) = siglmd(k)
+ enddo
+#endif
+#if(PA)
+ ! +- Vertical Discretisation of Parish Model
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do k = 1, 10
+ sigma(k) = sigpar(k)
+ enddo
+ mmz = mz
+ if(mmz > 10) then
+ if(mmz == 11) sigma(11) = sigp11
+ if(mmz == 12) then
+ do k = 11, 12
+ sigma(k) = sigp12(k)
+ enddo
+ endif
+ if(mmz == 13) then
+ do k = 10, 13
+ sigma(k) = sigp13(k)
+ enddo
+ endif
+ endif
+#endif
+ do k = 1, mz
+ if(abs(gaz) > 1.d-5) then
+ zsigma(k) = -(sst_SL / gaz) * ((1.e0 + (sigma(k) - 1.e0) &
+ * (1.e2 / ps_sig))**(RDryAi * gaz / gravit) - 1.e0)
+ else
+ if(IO_loc >= 2 .and. k == 1) write(21, 116)
+116 format(/, ' t(z) = CONSTANT')
+ zsigma(k) = -(RDryAi * sst_SL / gravit) * log((unun + (sigma(k) - unun) &
+ * (1.d2 / ps_sig)))
+ endif
+ enddo
+ else
+ ! +- 2) Fine Resolution of the Surface Layer
+ ! + -----------------------------------------
+ gaz = max(gaz, epsi)
+ km = 2
+ km = min(km, mz)
+ kn = 1
+#if(L1)
+ kn = 2
+#endif
+ zsigma(1) = zmin
+ zsigma(km) = 2.0 * zmin
+ do k = min(3, mz), mz
+ rz = zmin * aavu**(k - 1)
+ rzb = ccvu * bbvu**(k - 1)
+ if(TUkhmx > 0.0) then
+ zsigma(k) = rzb * rz / (rz + rzb)
+ else
+ zsigma(k) = rz
+ endif
+
+ zsigma(k) = max(zsigma(k), zsigma(k - 1) + zsigma(kn))
+ enddo
+ ! sh_min_0 : Everest
+ sh_min = 8807.0
+ do j = 1, my
+ do i = 1, mx
+ sh_min = min(sh_min, sh(i, j))
+ enddo
+ enddo
+ ps_max = ps_sig * (1.0 - gaz * sh_min / sst_SL) &
+ **(gravit / (gaz * RDryAi))
+ pstar0 = ps_max - ptopDY
+ do k = 1, mz
+ kk = mz + 1 - k
+ ! sigma(kk): the fine resolution of the surface layer
+ ! is computed using a geometric progression
+ sigma(kk) = (ps_sig / pstar0) &
+ * ((1.0 - gaz * (sh_min + zsigma(k)) / sst_SL) &
+ **(gravit / (gaz * RDryAi)) &
+ - 1.0) &
+ + 1.0 + (ps_sig - ps_max) / pstar0
+ enddo
+ endif
+
+ ! +--Output
+ ! + ======
+ do k = 1, mz
+ kk = mzz - k
+ WKxza(1, k) = zsigma(kk)
+ enddo
+
+ do k = 1, mz
+ zsigma(k) = WKxza(1, k)
+ WKxza(1, k) = 0.0
+ enddo
+
+ if(IO_loc >= 2) then
+ write(21, 130)(sigma(k), k=1, mz)
+130 format(/, ' Sigma Levels :', /,(1x, 15f8.4))
+ write(21, 131)(zsigma(k), k=1, mz)
+131 format(/, ' Altitude Levels :', /,(1x, 15f8.1))
+ endif
+ return
+endsubroutine grdsig
diff --git a/MAR/code_mar/grdstr.f90 b/MAR/code_mar/grdstr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..98c7a8d3e405a35887b8952145948f18818b428d
--- /dev/null
+++ b/MAR/code_mar/grdstr.f90
@@ -0,0 +1,119 @@
+#include "MAR_pp.def"
+subroutine grdstr(xxmar, yymar, GE0lon, GE0lat, GElonM, GElatM, GEtruL)
+ ! +------------------------------------------------------------------------+
+ ! | MAR GRID 19-11-2004 MAR |
+ ! | subroutine grdstr computes the Latitudes, Longitudes |
+ ! | of a MAR Domain Grid Point |
+ ! | assuming Inverse Stereographic Oblique Projection |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: xxmar ,yymar : MAR Coordinates |
+ ! | ^^^^^^ GE0lon,GE0lat: Geographic Coordinates of MAR Domain Center |
+ ! | (3-D): South-North Direction along |
+ ! | 90E, 180E, 270E or 360E Meridians |
+ ! | |
+ ! | OUTPUT: GElatM : Latitude of the MAR grid point (radian) |
+ ! | ^^^^^^^ GElonM : Longitude of the MAR grid point (hour) |
+ ! | |
+ ! | REFERENCE: F. Pearson, Map projection methods, CRC Press, 1990. |
+ ! | ^^^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+
+ implicit none
+
+ ! +--local Parameters
+ ! + =================
+ integer i, j, k, m
+ real pidemi, CphiP, SphiP, Sphi
+ real dGElon, GElonM, GElatM
+ real GEtruL, GE0lon, GE0lat
+ real denomi, OBLlon, OBLlat
+ real ddista, xxmar, yymar
+ real costru
+
+ pidemi = pi / 2.0
+
+ CphiP = cos(degrad * GE0lat)
+ SphiP = sin(degrad * GE0lat)
+
+ costru = cos(degrad * GEtruL)
+
+ ! +--Coordinates relative to a Pole set to the Domain Center
+ ! + =======================================================
+
+ ! +--Relative Longitude -OBLlon (0 <= OBLlon < 2pi)
+ ! + ----------------------------------------------
+ if(xxmar > 0.) then
+ OBLlon = pidemi - atan(yymar / xxmar)
+ else if(xxmar == 0. .and. yymar < 0.) then
+ OBLlon = pi
+ else if(xxmar < 0.) then
+ OBLlon = 3.00 * pidemi - atan(yymar / xxmar)
+ else if(xxmar == 0. .and. yymar >= 0.) then
+ OBLlon = 0.0
+ endif
+
+ ! +--Relative Latitude OBLlat
+ ! + --------------------------
+ ddista = sqrt(xxmar * xxmar + yymar * yymar)
+ OBLlat = 0.50 * pi - 2.0 * atan(ddista / (earthr * (1.+costru)))
+
+ ! +--Coordinates Change (OBLlon,OBLlat) -> (GElonM,GElatM)
+ ! + / (rotation, Pearson p.57)
+ ! + =====================================================
+
+ ! +--Latitude (radians)
+ ! + ------------------
+ Sphi = SphiP * sin(OBLlat) + CphiP * cos(OBLlat) * cos(OBLlon)
+ GElatM = asin(Sphi)
+
+ ! +--Longitude (hours)
+ ! + ------------------
+ ! +--dGElon = GElonM - GE0lon (-pi < dGElon <= pi)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ denomi = CphiP * tan(OBLlat) - SphiP * cos(OBLlon)
+
+ if(OBLlon > epsi .and. OBLlon < (pi - epsi)) then
+ ! +--1) OBLlon in trigonometric quadrant 1 or 4 ("right"):
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dGElon = atan(sin(OBLlon) / denomi)
+ if(dGElon < 0.0) then
+ ! Go to Quadrant 1 by adding180 degrees
+ dGElon = dGElon + pi
+ endif
+ ! +--2) OBLlon is in trigonometric quadrant 2or3 ("left "):
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(OBLlon > (pi + epsi) .and. OBLlon < (2.0 * pi - epsi)) then
+ dGElon = atan(sin(OBLlon) / denomi)
+ if(dGElon > 0.0) then
+ ! Go to Quadrant 2 by substracting 180 degrees
+ dGElon = dGElon - pi
+ endif
+ else if(OBLlon <= epsi .or. OBLlon >= (2.0 * pi - epsi)) then
+ ! +--3) OBLlon = 0 -> dGElon = 0 or pi :
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if((pidemi - OBLlat) > (pidemi - degrad * GE0lat)) then
+ ! North pole crossed ==> add 180 degrees to Longitude
+ dGElon = pi
+ else
+ dGElon = 0.0
+ endif
+ else if(OBLlon >= (pi - epsi) .and. OBLlon <= (pi + epsi)) then
+ ! +--4) OBLlon = pi -> dGElon = 0 or pi :
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if((pidemi - OBLlat) > (pidemi + degrad * GE0lat)) then
+ ! South pole crossed ==> add 180 degrees to Longitude
+ dGElon = pi
+ else
+ dGElon = 0.0
+ endif
+ endif
+ ! +--Longitude (hours)
+ ! + ~~~~~~~~~
+ GElonM = (dGElon + GE0lon * degrad) / hourad
+ return
+endsubroutine grdstr
diff --git a/MAR/code_mar/hydadv_ver.f90 b/MAR/code_mar/hydadv_ver.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f5ea1dbc1a0307623ac271e58439f6229c8bab42
--- /dev/null
+++ b/MAR/code_mar/hydadv_ver.f90
@@ -0,0 +1,2260 @@
+#include "MAR_pp.def"
+subroutine HYDadv_ver
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS SLOW 18-09-2001 MAR |
+ ! | subroutine HYDadv_ver includes the Vertical Advection Contribution |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ iterun : Run Iteration Counter |
+ ! | qvDY, qwHY, qrHY, qiHY, ccniHY, qsHY / Time Step n |
+ ! | qwHY : Cloud Droplets Concentration (kg/kg) |
+ ! | qrHY : Rain Drops Concentration (kg/kg) |
+ ! | qvDY : Water Vapor Concentration (kg/kg) |
+ ! | qiHY : Ice Crystals Concentration (kg/kg) |
+ ! | ccniHY : Ice Crystals Number |
+ ! | qsHY : Snow Flakes Concentration (kg/kg) |
+ ! | |
+ ! | OUTPUT : qvDY, qwHY, qrHY, qiHY, ccniHY, qsHY / Time Step n+1 |
+ ! | ^^^^^^^^ |
+ ! | |
+ ! | METHOD: Unstaggered Grid: 1st Accurate in Space Upstream Scheme |
+ ! | ^^^^^^^^ Staggered Grid: 2nd Accurate in Space |
+ ! | |
+ ! | # OPTIONS: #VA: Vertical Average preferred in Centered Conserv Scheme |
+ ! | # ^^^^^^^^ #NS: NO Slip Surface BC used in Centered Conserv Scheme |
+ ! | # #WF: Water Conservation along the Vertical |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_hy
+ use mar_sl
+ use mar_wk
+#if(cA)
+ use mar_ca
+#endif
+
+ implicit none
+
+#if(WA)
+ integer nadvrd
+ common / DYNadv_ver_loc / nadvrd
+#endif
+
+ logical centrL
+#if(ZU)
+ logical adv3rd
+ real gat(mx, my, mz), ga0(mx, my)
+ data adv3rd/.true./
+#endif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer ntimax, itimax
+
+ real cflmax, cflsig, faccfl, dsgm
+ real old__u, old__v, old__t
+ real qw_0, qr_0, qv_0, qi_0, ccni_0, qs_0
+#if(WF)
+ real qwVC, qrVC, qvVC, qiVC, ciVC, qsVC
+#endif
+#if(BS)
+ real dh_sno
+#endif
+
+ ! +--DATA
+ ! + ====
+ data centrL/.true./
+#if(UP)
+ centrL = .false.
+#endif
+
+ ! +--Slip condition for Mountain Wave Experiments
+ ! + ============================================
+
+#if(OM)
+ do j = jp11, my1
+ do i = ip11, mx1
+ psigDY(i, j, mz) = 0.0
+ enddo
+ enddo
+#endif
+
+ ! +--First and Second Order Schemes
+ ! + ==============================
+
+#if(ZU)
+ if(.not. adv3rd) then
+#endif
+
+ ! +--Courant Number
+ ! + --------------
+
+ cflmax = 0.0
+
+ ! +--Centered second Order Scheme on a staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(centrL .and. staggr) then
+
+#if(WA)
+ write(6, 6001) iterun
+6001 format(i6, ' 6001 centrL .and. staggr /CFL Number')
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = dt * psigDY(i, j, k) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz7(i, j, k) + WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, 1) = 0.00
+ enddo
+ enddo
+
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = dt * psigDY(i, j, km1(k)) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz8(i, j, k) + WKxyz8(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ else
+
+ ! +--Upstream first Order Scheme on a staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(staggr) then
+
+#if(WA)
+ write(6, 6002) iterun
+6002 format(i6, ' 6002 .not. centrL .and. staggr /Wind Speed')
+#endif
+
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = (psigDY(i, j, k - 1) * dsig_1(k - 1) &
+ + psigDY(i, j, k) * dsig_1(k)) &
+ / (dsig_1(k - 1) + dsig_1(k))
+ enddo
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, 1) = psigDY(i, j, 1) * dsig_1(1) &
+ / (dsig_1(0) + dsig_1(1))
+ enddo
+ enddo
+
+ ! +--Upstream first Order Scheme on a non staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+#if(WA)
+ write(6, 6003) iterun
+6003 format(i6, ' 6003 (.not.)centrL.and. .not. staggr /Wind Speed')
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = psigDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ! +--Centered second Order Scheme on a non staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(centrL) then
+
+#if(WA)
+ write(6, 6004) iterun
+6004 format(i6, ' 6004 centrL.and. .not. staggr /CFL Number')
+#endif
+
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = dt * WKxyz8(i, j, k) &
+ / (pstDYn(i, j) * dsigm1(k) * 2.0)
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ ! +--Upstream first Order Scheme on a (non) staggered Grid
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+#if(WA)
+ write(6, 6005) iterun
+6005 format(i6, ' 6005 .not. centrL.and.(.not.)staggr /CFL Number')
+#endif
+
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(WKxyz8(i, j, k) > 0.0) then
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k - 1))
+ else
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k))
+ endif
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+ enddo
+
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(WKxyz8(i, j, k) > 0.0) then
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k - 1))
+ else
+ WKxyz7(i, j, k) = -dt * WKxyz8(i, j, k) / (pstDYn(i, j) * dsig_1(k))
+ endif
+ cflsig = abs(WKxyz7(i, j, k))
+ cflmax = max(cflsig, cflmax)
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WKxyz7(i, j, 1) = 0.0
+ enddo
+ enddo
+
+ ! +--Work Array Reset
+ ! + ~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ endif
+
+ ! +--Set Up of the Local Split Time Differencing
+ ! + ----------------------------------------------
+
+ cflmax = 2.0 * cflmax
+ ! +... restricted CFL Criterion
+
+ ntimax = cflmax
+ if(centrL) then
+ ntimax = max(2, ntimax)
+#if(WA)
+ write(6, 6006) ntimax
+6006 format(i6, ' 6006 centrL.and.(.not.)staggr /Nb Iterat.')
+#endif
+ else
+ ntimax = max(1, ntimax)
+#if(WA)
+ write(6, 6007) ntimax
+6007 format(i6, ' 6007 .not. centrL.and.(.not.)staggr /Nb Iterat.')
+#endif
+ endif
+
+ ! +--Update of CFL Number
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ if(ntimax > 1) then
+ faccfl = 1.0d+0 / ntimax
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz7(i, j, k) = WKxyz7(i, j, k) * faccfl
+ WKxyz8(i, j, k) = WKxyz8(i, j, k) * faccfl
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! +--OUTPUT for Verification
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+#if(WA)
+ nadvrd = nadvrd + 1
+ write(6, 6000) nadvrd, cflmax, ntimax
+6000 format(i6, ' CFLmax ', 3x, ' ', 3x, ' =', f7.4, &
+ 6x, ' ntimax ', 8x, ' =', i4)
+#endif
+
+ ! +--Warm Water Conservation
+ ! + -----------------------
+#if(WF)
+ do j = 1, my
+ do i = 1, mx
+ WKxy4(i, j) = 0.0d+0
+ WKxy5(i, j) = 0.0d+0
+ WKxy6(i, j) = 0.0d+0
+ WKxy7(i, j) = 0.0d+0
+ WKxy8(i, j) = 0.0d+0
+ WKxy9(i, j) = 0.0d+0
+ do k = 1, mz
+ WKxy4(i, j) = WKxy4(i, j) + dsigm1(k) * qvDY(i, j, k)
+ WKxy5(i, j) = WKxy5(i, j) + dsigm1(k) * qwHY(i, j, k)
+ WKxy6(i, j) = WKxy6(i, j) + dsigm1(k) * qrHY(i, j, k)
+ WKxy7(i, j) = max(WKxy7(i, j), qvDY(i, j, k))
+ WKxy8(i, j) = max(WKxy8(i, j), qwHY(i, j, k))
+ WKxy9(i, j) = max(WKxy9(i, j), qrHY(i, j, k))
+ enddo
+ enddo
+ enddo
+#endif
+
+ ! +--Warm Water
+ ! +--Start Vertical Advection
+ ! + ------------------------
+
+ if(centrL) then
+
+ if(staggr) then
+
+#if(WA)
+ write(6, 6008)
+6008 format(6x, ' 6008 centrL.and. staggr /A Contrib.')
+#endif
+
+ ! +--2nd Order Centered Energy conserving: Local Split Time Differencing
+ ! + ~~~~~~~~~ (Haltiner & Williams 1980 7.2.2, (7-47b) p.220) ~~~~~~~~~~
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do itimax = 1, ntimax
+
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+
+ do j = jp11, my1
+
+ ! +--Vertical Differences
+
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = qwHY(i, j, k)
+ WKxzq(i, k) = qrHY(i, j, k)
+ WKxzx(i, k) = qvDY(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (qwHY(i, j, k) * dsigm1(k) * 2.0 &
+ + qwHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (qrHY(i, j, k) * dsigm1(k) * 2.0 &
+ + qrHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (qvDY(i, j, k) * dsigm1(k) * 2.0 &
+ + qvDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ qw_0 = WKxzp(i, k)
+ WKxza(i, k) = (WKxzp(i, k) - qw_0)
+ qr_0 = WKxzq(i, k)
+ WKxzb(i, k) = (WKxzq(i, k) - qr_0)
+ qv_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qv_0)
+ enddo
+
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = qwHY(i, j, k)
+ WKxzq(i, k) = qrHY(i, j, k)
+ WKxzx(i, k) = qvDY(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (qwHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qwHY(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + qwHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (qrHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qrHY(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + qrHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (qvDY(i, j, k - 1) * dsigm1(k - 1) &
+ + qvDY(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + qvDY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = qwHY(i, j, k)
+ WKxzq(i, k) = qrHY(i, j, k)
+ WKxzx(i, k) = qvDY(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (qwHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qwHY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (qrHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qrHY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (qvDY(i, j, k - 1) * dsigm1(k - 1) &
+ + qvDY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (qvapSL(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+
+ ! +--Advection Contribution
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ WKxyz1(i, j, k) = qwHY(i, j, k) - WKxzd(i, k)
+ WKxyz4(i, j, k) = qwHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ WKxyz2(i, j, k) = qrHY(i, j, k) - WKxzd(i, k)
+ WKxyz5(i, j, k) = qrHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = qvDY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = qvDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ WKxyz1(i, j, k) = qwHY(i, j, k) - WKxzd(i, k)
+ WKxyz4(i, j, k) = qwHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ WKxyz2(i, j, k) = qrHY(i, j, k) - WKxzd(i, k)
+ WKxyz5(i, j, k) = qrHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = qvDY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = qvDY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+
+ enddo
+
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+
+ ! +--Vertical Differences
+
+ do j = jp11, my1
+
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ qw_0 = WKxzp(i, k)
+ WKxza(i, k) = (WKxzp(i, k) - qw_0)
+ qr_0 = WKxzq(i, k)
+ WKxzb(i, k) = (WKxzq(i, k) - qr_0)
+ qv_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qv_0)
+ enddo
+
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (qvapSL(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+
+ ! +--Advection Contribution
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+
+ enddo
+
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+
+ do j = jp11, my1
+
+ ! +--Vertical Differences
+
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ qw_0 = WKxzp(i, k)
+ WKxza(i, k) = (WKxzp(i, k) - qw_0)
+ qr_0 = WKxzq(i, k)
+ WKxzb(i, k) = (WKxzq(i, k) - qr_0)
+ qv_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qv_0)
+ enddo
+
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0d+0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0d+0) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0d+0) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0d+0) / dsgm
+#endif
+ enddo
+
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (qvapSL(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+
+ ! +--Hydromet.Advection
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+ qwHY(i, j, k) = WKxyz1(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k))
+ qrHY(i, j, k) = WKxyz2(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k))
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+ qwHY(i, j, k) = WKxyz1(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k))
+ qrHY(i, j, k) = WKxyz2(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k))
+ enddo
+
+ ! +--Wat.Vapr.Advect.avoids double Counting in case of convective Adjustment
+
+ do k = 1, mmz1
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+
+ k = mmz
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+#if(cA)
+ endif
+#endif
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+
+ ! +--Warm Water
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+
+ enddo
+
+ ! +--Warm Water
+ ! +--2nd Order Centered Leap-Frog Backward: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ else
+ ! +
+#if(WA)
+ write(6, 6009)
+6009 format(6x, ' 6009 centrL.and. .not. staggr /A Contrib.')
+#endif
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Advection Increment
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qw_0 = qwHY(i, j, k)
+ WKxza(i, k) = (qwHY(i, j, k + 1) - qw_0) &
+ * WKxyz7(i, j, k)
+ qr_0 = qrHY(i, j, k)
+ WKxzb(i, k) = (qrHY(i, j, k + 1) - qrHY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ qv_0 = qvDY(i, j, k)
+ WKxzc(i, k) = (qvDY(i, j, k + 1) - qvDY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (qwHY(i, j, k + 1) - qwHY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (qrHY(i, j, k + 1) - qrHY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qvDY(i, j, k + 1) - qvDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -qwHY(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -qrHY(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qvapSL(i, j) - qvDY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qwHY(i, j, k) - WKxza(i, k)
+ WKxyz4(i, j, k) = qwHY(i, j, k) - (WKxza(i, k) + WKxza(i, k))
+ WKxyz2(i, j, k) = qrHY(i, j, k) - WKxzb(i, k)
+ WKxyz5(i, j, k) = qrHY(i, j, k) - (WKxzb(i, k) + WKxzb(i, k))
+ WKxyz3(i, j, k) = qvDY(i, j, k) - WKxzc(i, k)
+ WKxyz6(i, j, k) = qvDY(i, j, k) - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+ ! +
+ ! +--Advection Increment
+ ! +
+ do j = jp11, my1
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qw_0 = WKxyz4(i, j, k)
+ qr_0 = WKxyz5(i, j, k)
+ qv_0 = WKxyz6(i, j, k)
+ ! +
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - qw_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - qr_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - qv_0) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qvapSL(i, j) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxza(i, k) + WKxza(i, k))
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzb(i, k) + WKxzb(i, k))
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Advection Increment
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qw_0 = WKxyz4(i, j, k)
+ qr_0 = WKxyz5(i, j, k)
+ qv_0 = WKxyz6(i, j, k)
+ ! +
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - qw_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - qr_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - qv_0) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qvapSL(i, j) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Hydromet.Advection
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ qwHY(i, j, k) = WKxyz1(i, j, k) - WKxza(i, k)
+ qrHY(i, j, k) = WKxyz2(i, j, k) - WKxzb(i, k)
+ enddo
+ ! +
+ ! +--Wat.Vapr.Advect.avoids double Counting in case of convective Adjustment
+ ! +
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k) - WKxzc(i, k)
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Warm Water
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Warm Water
+ ! +--First Order Upstream Scheme: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ else
+ ! +
+#if(WA)
+ write(6, 6010)
+6010 format(6x, ' 6010 .not. centrL.and.(.not.)staggr /A Contrib.')
+#endif
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--Auxiliary Variables
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(WA)
+ write(6, 6011) itimax, WKxyz1(imez, jmez, mz1), WKxyz1(imez, jmez, mz) &
+ , qwHY(imez, jmez, mz1), qwHY(imez, jmez, mz)
+6011 format(6x, ' 6011 .not. centrL.and.(.not.)staggr /A Contrib.', &
+ 4f9.6)
+#endif
+ ! +
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qwHY(i, j, k)
+ WKxyz2(i, j, k) = qrHY(i, j, k)
+ WKxyz3(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Vertical Differences
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ k = 1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = 0.0d+0
+ WKxyz5(i, j, k) = 0.0d+0
+ WKxyz6(i, j, k) = 0.0d+0
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz1(i, j, k) - WKxyz1(i, j, k - 1)
+ WKxyz5(i, j, k) = WKxyz2(i, j, k) - WKxyz2(i, j, k - 1)
+ WKxyz6(i, j, k) = WKxyz3(i, j, k) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mzz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxy1(i, j) = -WKxyz1(i, j, k - 1)
+ WKxy2(i, j) = -WKxyz2(i, j, k - 1)
+ WKxy3(i, j) = qvapSL(i, j) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qwHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k + 1)
+ WKxyz2(i, j, k) = qrHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k + 1)
+ WKxyz3(i, j, k) = qvDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k + 1)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qwHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy1(i, j)
+ WKxyz2(i, j, k) = qrHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy2(i, j)
+ WKxyz3(i, j, k) = qvDY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy3(i, j)
+ enddo
+ enddo
+ ! +
+ ! +--Wind Update
+ ! + ~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qwHY(i, j, k) = WKxyz1(i, j, k)
+ qrHY(i, j, k) = WKxyz2(i, j, k)
+ enddo
+ ! +
+ ! +--Pot.Temp.Update avoids double Counting in case of convective Adjustment
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = ip11, mx1
+#if(cA)
+ if(adj_CA(i, j) == 0) then
+#endif
+ qvDY(i, j, k) = WKxyz3(i, j, k)
+#if(cA)
+ endif
+#endif
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+#if(WA)
+ write(6, 6012) itimax, WKxyz1(imez, jmez, mz1), WKxyz1(imez, jmez, mz) &
+ , qwHY(imez, jmez, mz1), qwHY(imez, jmez, mz)
+6012 format(6x, ' 6012 .not. centrL.and.(.not.)staggr /A Contrib.', &
+ 4f9.6)
+#endif
+ enddo
+ ! +
+ endif
+#if(WF)
+ ! +
+ ! +
+ ! +--Warm Water Conservation
+ ! + -----------------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ qvVC = 0.0d+0
+ qwVC = 0.0d+0
+ qrVC = 0.0d+0
+ do k = 1, mz
+ ! +
+ ! +--Flux Limitor
+ ! + ~~~~~~~~~~~~
+ qvDY(i, j, k) = max(eps9, qvDY(i, j, k))
+ qvDY(i, j, k) = min(WKxy7(i, j), qvDY(i, j, k))
+ qwHY(i, j, k) = max(zero, qwHY(i, j, k))
+ qwHY(i, j, k) = min(WKxy8(i, j), qwHY(i, j, k))
+ qrHY(i, j, k) = max(zero, qrHY(i, j, k))
+ qrHY(i, j, k) = min(WKxy9(i, j), qrHY(i, j, k))
+ ! +
+ ! +--Column Average
+ ! + ~~~~~~~~~~~~~~
+ qvVC = qvVC + dsigm1(k) * qvDY(i, j, k)
+ qwVC = qwVC + dsigm1(k) * qwHY(i, j, k)
+ qrVC = qrVC + dsigm1(k) * qrHY(i, j, k)
+ enddo
+ ! +
+ ! +--Surface Boundary Flux
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ qvVC = qvVC - psigDY(i, j, mz) &
+ * (qvDY(i, j, mz) - qvapSL(i, j)) * dt / pstDYn(i, j)
+ qwVC = qwVC - psigDY(i, j, mz) &
+ * qwHY(i, j, mz) * dt / pstDYn(i, j)
+ qrVC = qrVC - psigDY(i, j, mz) &
+ * qrHY(i, j, mz) * dt / pstDYn(i, j)
+ ! +
+ ! +--Mass Restore
+ ! + ~~~~~~~~~~~~
+ do k = 1, mz
+ qvDY(i, j, k) = qvDY(i, j, k) * WKxy4(i, j) / max(eps12, qvVC)
+ qwHY(i, j, k) = qwHY(i, j, k) * WKxy5(i, j) / max(eps12, qwVC)
+ qrHY(i, j, k) = qrHY(i, j, k) * WKxy6(i, j) / max(eps12, qrVC)
+ enddo
+ enddo
+ enddo
+#endif
+ ! +
+ ! +
+ ! +--Warm Water
+ ! +--Work Arrays Reset
+ ! + -----------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ WKxy4(i, j) = 0.0
+ WKxy5(i, j) = 0.0
+ WKxy6(i, j) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do i = 1, mx
+ WKxza(i, k) = 0.0
+ WKxzb(i, k) = 0.0
+ WKxzc(i, k) = 0.0
+ WKxzd(i, k) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ ! +
+#if(WF)
+ ! +
+ ! +--Ice Water Conservation
+ ! + -----------------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy4(i, j) = 0.0d+0
+ WKxy5(i, j) = 0.0d+0
+ WKxy6(i, j) = 0.0d+0
+ WKxy7(i, j) = 0.0d+0
+ WKxy8(i, j) = 0.0d+0
+ WKxy9(i, j) = 0.0d+0
+ do k = 1, mz
+ WKxy4(i, j) = WKxy4(i, j) + dsigm1(k) * ccniHY(i, j, k)
+ WKxy5(i, j) = WKxy5(i, j) + dsigm1(k) * qiHY(i, j, k)
+ WKxy6(i, j) = WKxy6(i, j) + dsigm1(k) * qsHY(i, j, k)
+ WKxy7(i, j) = max(WKxy7(i, j), ccniHY(i, j, k))
+ WKxy8(i, j) = max(WKxy8(i, j), qiHY(i, j, k))
+ WKxy9(i, j) = max(WKxy9(i, j), qsHY(i, j, k))
+ enddo
+ enddo
+ enddo
+ ! +
+#endif
+ ! +
+ ! +--Ice Water
+ ! +--Start Vertical Advection
+ ! + ------------------------
+ ! +
+ if(centrL) then
+ ! +
+ if(staggr) then
+ ! +
+ ! +--2nd Order Centered Energy conserving: Local Split Time Differencing
+ ! + ~~~~~~~~~ (Haltiner & Williams 1980 7.2.2, (7-47b) p.220) ~~~~~~~~~~
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do itimax = 1, ntimax
+ ! +
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Vertical Differences
+ ! +
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = qiHY(i, j, k)
+ WKxzq(i, k) = ccniHY(i, j, k)
+ WKxzx(i, k) = qsHY(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (qiHY(i, j, k) * dsigm1(k) * 2.0 &
+ + qiHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (ccniHY(i, j, k) * dsigm1(k) * 2.0 &
+ + ccniHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (qsHY(i, j, k) * dsigm1(k) * 2.0 &
+ + qsHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ qi_0 = WKxzp(i, k)
+ WKxza(i, k) = (WKxzp(i, k) - qi_0)
+ ccni_0 = WKxzq(i, k)
+ WKxzb(i, k) = (WKxzq(i, k) - ccni_0)
+ qs_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qs_0)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = qiHY(i, j, k)
+ WKxzq(i, k) = ccniHY(i, j, k)
+ WKxzx(i, k) = qsHY(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (qiHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qiHY(i, j, k) * dsigm1(k) * 2.0 &
+ + qiHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (ccniHY(i, j, k - 1) * dsigm1(k - 1) &
+ + ccniHY(i, j, k) * dsigm1(k) * 2.0 &
+ + ccniHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (qsHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qsHY(i, j, k) * dsigm1(k) * 2.0 &
+ + qsHY(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = qiHY(i, j, k)
+ WKxzq(i, k) = ccniHY(i, j, k)
+ WKxzx(i, k) = qsHY(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (qiHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qiHY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (ccniHY(i, j, k - 1) * dsigm1(k - 1) &
+ + ccniHY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (qsHY(i, j, k - 1) * dsigm1(k - 1) &
+ + qsHY(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ ! +
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (qsrfHY(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ WKxyz1(i, j, k) = qiHY(i, j, k) - WKxzd(i, k)
+ WKxyz4(i, j, k) = qiHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ WKxyz2(i, j, k) = ccniHY(i, j, k) - WKxzd(i, k)
+ WKxyz5(i, j, k) = ccniHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = qsHY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = qsHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ WKxyz1(i, j, k) = qiHY(i, j, k) - WKxzd(i, k)
+ WKxyz4(i, j, k) = qiHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ WKxyz2(i, j, k) = ccniHY(i, j, k) - WKxzd(i, k)
+ WKxyz5(i, j, k) = ccniHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ WKxyz3(i, j, k) = qsHY(i, j, k) - WKxzd(i, k)
+ WKxyz6(i, j, k) = qsHY(i, j, k) - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+ ! +
+ ! +--Vertical Differences
+ ! +
+ do j = jp11, my1
+ ! +
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ qi_0 = WKxzp(i, k)
+ WKxza(i, k) = (WKxzp(i, k) - qi_0)
+ ccni_0 = WKxzq(i, k)
+ WKxzb(i, k) = (WKxzq(i, k) - ccni_0)
+ qs_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qs_0)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ ! +
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0d+0
+ WKxy2(i, j) = 0.0d+0
+ WKxy3(i, j) = 0.0d+0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (qsrfHY(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k)
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k)
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzd(i, k) + WKxzd(i, k))
+ ! +
+ WKxzd(i, k) = WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k)
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzd(i, k) + WKxzd(i, k))
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Vertical Differences
+ ! +
+ k = 1
+ dsgm = 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ qi_0 = WKxzp(i, k)
+ WKxza(i, k) = (WKxzp(i, k) - qi_0)
+ ccni_0 = WKxzq(i, k)
+ WKxzb(i, k) = (WKxzq(i, k) - ccni_0)
+ qs_0 = WKxzx(i, k)
+ WKxzc(i, k) = (WKxzx(i, k) - qs_0)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k) + dsigm1(k + 1)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz4(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz5(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0 &
+ + WKxyz6(i, j, k + 1) * dsigm1(k + 1)) / dsgm
+#endif
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ dsgm = dsigm1(k - 1) + 2.0 * dsigm1(k)
+ do i = ip11, mx1
+ WKxzp(i, k) = WKxyz4(i, j, k)
+ WKxzq(i, k) = WKxyz5(i, j, k)
+ WKxzx(i, k) = WKxyz6(i, j, k)
+ ! +
+#if(VA)
+ WKxzp(i, k) = (WKxyz4(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz4(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzq(i, k) = (WKxyz5(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz5(i, j, k) * dsigm1(k) * 2.0) / dsgm
+ WKxzx(i, k) = (WKxyz6(i, j, k - 1) * dsigm1(k - 1) &
+ + WKxyz6(i, j, k) * dsigm1(k) * 2.0) / dsgm
+#endif
+ enddo
+ ! +
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxzp(i, k) - WKxzp(i, k - 1))
+ WKxzb(i, k) = (WKxzq(i, k) - WKxzq(i, k - 1))
+ WKxzc(i, k) = (WKxzx(i, k) - WKxzx(i, k - 1))
+ enddo
+ ! +
+ k = mzz
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+#if(NS)
+ WKxy1(i, j) = -WKxzp(i, k - 1)
+ WKxy2(i, j) = -WKxzq(i, k - 1)
+ WKxy3(i, j) = (qsrfHY(i, j) - WKxzx(i, k - 1))
+#endif
+ enddo
+ ! +
+ ! +--Hydromet.Advection
+ ! +
+ do k = 1, mmz1
+ do i = ip11, mx1
+ qiHY(i, j, k) = WKxyz1(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxza(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxza(i, k))
+ ccniHY(i, j, k) = WKxyz2(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzb(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzb(i, k))
+ qsHY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxzc(i, k + 1) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ qiHY(i, j, k) = WKxyz1(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy1(i, j) &
+ + WKxyz8(i, j, k) * WKxza(i, k))
+ ccniHY(i, j, k) = WKxyz2(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy2(i, j) &
+ + WKxyz8(i, j, k) * WKxzb(i, k))
+ qsHY(i, j, k) = WKxyz3(i, j, k) &
+ - (WKxyz7(i, j, k) * WKxy3(i, j) &
+ + WKxyz8(i, j, k) * WKxzc(i, k))
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Ice Water
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ enddo
+ ! +
+ ! +
+ ! +--Ice Water
+ ! +--2nd Order Centered Leap-Frog Backward: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ else
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--First internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itimax == 1) then
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Advection Increment
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qi_0 = qiHY(i, j, k)
+ WKxza(i, k) = (qiHY(i, j, k + 1) - qi_0) &
+ * WKxyz7(i, j, k)
+ ccni_0 = ccniHY(i, j, k)
+ WKxzb(i, k) = (ccniHY(i, j, k + 1) - ccniHY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ qv_0 = qsHY(i, j, k)
+ WKxzc(i, k) = (qsHY(i, j, k + 1) - qsHY(i, j, k)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (qiHY(i, j, k + 1) - qiHY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (ccniHY(i, j, k + 1) - ccniHY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qsHY(i, j, k + 1) - qsHY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -qiHY(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -ccniHY(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qsrfHY(i, j) - qsHY(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qiHY(i, j, k) - WKxza(i, k)
+ WKxyz4(i, j, k) = qiHY(i, j, k) - (WKxza(i, k) + WKxza(i, k))
+ WKxyz2(i, j, k) = ccniHY(i, j, k) - WKxzb(i, k)
+ WKxyz5(i, j, k) = ccniHY(i, j, k) - (WKxzb(i, k) + WKxzb(i, k))
+ WKxyz3(i, j, k) = qsHY(i, j, k) - WKxzc(i, k)
+ WKxyz6(i, j, k) = qsHY(i, j, k) - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Intermediary internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if(itimax < ntimax) then
+ ! +
+ ! +--Advection Increment
+ ! +
+ do j = jp11, my1
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qi_0 = WKxyz4(i, j, k)
+ ccni_0 = WKxyz5(i, j, k)
+ qv_0 = WKxyz6(i, j, k)
+ ! +
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - qi_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - ccni_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - qv_0) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qsrfHY(i, j) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ old__u = WKxyz1(i, j, k)
+ WKxyz1(i, j, k) = WKxyz4(i, j, k)
+ WKxyz4(i, j, k) = old__u - (WKxza(i, k) + WKxza(i, k))
+ old__v = WKxyz2(i, j, k)
+ WKxyz2(i, j, k) = WKxyz5(i, j, k)
+ WKxyz5(i, j, k) = old__v - (WKxzb(i, k) + WKxzb(i, k))
+ old__t = WKxyz3(i, j, k)
+ WKxyz3(i, j, k) = WKxyz6(i, j, k)
+ WKxyz6(i, j, k) = old__t - (WKxzc(i, k) + WKxzc(i, k))
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ ! +--Last internal Time Step
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+ ! +
+ do j = jp11, my1
+ ! +
+ ! +--Advection Increment
+ ! +
+ k = 1
+ do i = ip11, mx1
+ qi_0 = WKxyz4(i, j, k)
+ ccni_0 = WKxyz5(i, j, k)
+ qv_0 = WKxyz6(i, j, k)
+ ! +
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - qi_0) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - ccni_0) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - qv_0) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ do k = kp1(1), mmz1
+ do i = ip11, mx1
+ WKxza(i, k) = (WKxyz4(i, j, k + 1) - WKxyz4(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = (WKxyz5(i, j, k + 1) - WKxyz5(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (WKxyz6(i, j, k + 1) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ enddo
+ ! +
+ k = mmz
+ do i = ip11, mx1
+ WKxza(i, k) = -WKxyz4(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzb(i, k) = -WKxyz5(i, j, k - 1) &
+ * WKxyz7(i, j, k)
+ WKxzc(i, k) = (qsrfHY(i, j) - WKxyz6(i, j, k - 1)) &
+ * WKxyz7(i, j, k)
+ enddo
+ ! +
+ ! +--Hydromet.Advection
+ ! +
+ do k = 1, mmz
+ do i = ip11, mx1
+ qiHY(i, j, k) = WKxyz1(i, j, k) - WKxza(i, k)
+ ccniHY(i, j, k) = WKxyz2(i, j, k) - WKxzb(i, k)
+ qsHY(i, j, k) = WKxyz3(i, j, k) - WKxzc(i, k)
+ enddo
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Ice Water
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Ice Water
+ ! +--First Order Upstream Scheme: Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ else
+ ! +
+ do itimax = 1, ntimax
+ ! +
+ ! +--Auxiliary Variables
+ ! + ~~~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qiHY(i, j, k)
+ WKxyz2(i, j, k) = ccniHY(i, j, k)
+ WKxyz3(i, j, k) = qsHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +--Vertical Differences
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ k = 1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = 0.0d+0
+ WKxyz5(i, j, k) = 0.0d+0
+ WKxyz6(i, j, k) = 0.0d+0
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz1(i, j, k) - WKxyz1(i, j, k - 1)
+ WKxyz5(i, j, k) = WKxyz2(i, j, k) - WKxyz2(i, j, k - 1)
+ WKxyz6(i, j, k) = WKxyz3(i, j, k) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mzz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxy1(i, j) = -WKxyz1(i, j, k - 1)
+ WKxy2(i, j) = -WKxyz2(i, j, k - 1)
+ WKxy3(i, j) = qsrfHY(i, j) - WKxyz3(i, j, k - 1)
+ enddo
+ enddo
+ ! +
+ ! +--Advection Contribution
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do k = 1, mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qiHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k + 1)
+ WKxyz2(i, j, k) = ccniHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k + 1)
+ WKxyz3(i, j, k) = qsHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k + 1)
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = qiHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz4(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy1(i, j)
+ WKxyz2(i, j, k) = ccniHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz5(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy2(i, j)
+ WKxyz3(i, j, k) = qsHY(i, j, k) &
+ + min(zero, WKxyz7(i, j, k)) * WKxyz6(i, j, k) &
+ + max(zero, WKxyz7(i, j, k)) * WKxy3(i, j)
+ enddo
+ enddo
+ ! +
+ ! +--Hydrom. Update
+ ! + ~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qiHY(i, j, k) = WKxyz1(i, j, k)
+ ccniHY(i, j, k) = WKxyz2(i, j, k)
+ qsHY(i, j, k) = WKxyz3(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Ice Water
+ ! +--End of the Local Split Time Differencing
+ ! + --------------------------------------------------------------------
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+#if(WF)
+ ! +
+ ! +--Ice Water Conservation
+ ! + -----------------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ ciVC = 0.0d+0
+ qiVC = 0.0d+0
+ qsVC = 0.0d+0
+ do k = 1, mz
+ ! +
+ ! +--Flux Limitor
+ ! + ~~~~~~~~~~~~
+ ccniHY(i, j, k) = max(zero, ccniHY(i, j, k))
+ ccniHY(i, j, k) = min(WKxy7(i, j), ccniHY(i, j, k))
+ qiHY(i, j, k) = max(zero, qiHY(i, j, k))
+ qiHY(i, j, k) = min(WKxy8(i, j), qiHY(i, j, k))
+ qsHY(i, j, k) = max(zero, qsHY(i, j, k))
+ qsHY(i, j, k) = min(WKxy9(i, j), qsHY(i, j, k))
+ ! +
+ ! +--Column Average
+ ! + ~~~~~~~~~~~~~~
+ ciVC = ciVC + dsigm1(k) * ccniHY(i, j, k)
+ qiVC = qiVC + dsigm1(k) * qiHY(i, j, k)
+ qsVC = qsVC + dsigm1(k) * qsHY(i, j, k)
+ enddo
+ ! +
+ ! +--Surface Boundary Flux
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ ciVC = ciVC - psigDY(i, j, mz) &
+ * ccniHY(i, j, mz) * dt / pstDYn(i, j)
+ qiVC = qiVC - psigDY(i, j, mz) &
+ * qiHY(i, j, mz) * dt / pstDYn(i, j)
+ qsVC = qsVC - psigDY(i, j, mz) &
+ * (qsHY(i, j, mz) - qsrfHY(i, j)) * dt / pstDYn(i, j)
+ ! +
+ ! +--Mass Restore
+ ! + ~~~~~~~~~~~~
+ do k = 1, mz
+ ccniHY(i, j, k) = ccniHY(i, j, k) * (WKxy4(i, j) / max(eps12, ciVC))
+ qiHY(i, j, k) = qiHY(i, j, k) * WKxy5(i, j) / max(eps12, qiVC)
+ qsHY(i, j, k) = qsHY(i, j, k) * WKxy6(i, j) / max(eps12, qsVC)
+ enddo
+ enddo
+ enddo
+#endif
+ ! +
+ ! +
+ ! +--Work Arrays Reset
+ ! + -----------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ WKxy4(i, j) = 0.0
+ WKxy5(i, j) = 0.0
+ WKxy6(i, j) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do i = 1, mx
+ WKxza(i, k) = 0.0
+ WKxzb(i, k) = 0.0
+ WKxzc(i, k) = 0.0
+ WKxzd(i, k) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Courant Number
+ ! +--Work Arrays Reset
+ ! + -----------------
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Third Order Vertical Scheme
+ ! + ===========================
+#if(ZU)
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = 0.
+#endif
+#if(ZO)
+ ga0(i, j) = qwHY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = qwHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qwHY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+#if(ZO)
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = qrHY(i, j, mz)
+ enddo
+ enddo
+#endif
+#if(ZU)
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = qrHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qrHY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = qvapSL(i, j)
+#endif
+#if(ZO)
+ ga0(i, j) = qvDY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qvDY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = 0.0
+#endif
+#if(ZO)
+ ga0(i, j) = qiHY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = qiHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qiHY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+#if(ZO)
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = ccniHY(i, j, mz)
+ enddo
+ enddo
+#endif
+#if(ZU)
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = ccniHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ ccniHY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ do j = jp11, my1
+ do i = ip11, mx1
+ ga0(i, j) = qsrfHY(i, j)
+#endif
+#if(ZO)
+ ga0(i, j) = qsHY(i, j, mz)
+#endif
+#if(ZU)
+ enddo
+ enddo
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ gat(i, j, k) = qsHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ****************
+ call DYNadv_cubv(gat, ga0)
+ ! + ****************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qsHY(i, j, k) = gat(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+ ! +
+#if(BS)
+ ! +
+ ! +--Impact on Snow Erosion/Deposition
+ ! + =================================
+ ! +
+ do j = jp11, my1
+ do i = ip11, mx1
+ ! dh_sno contains an implicit factor 1.d3[kPa-->Pa]/ro_Wat[kg/m2-->mWE]
+ ! > 0 ==> Atmospheric Loss ==> Surface Gain
+ dh_sno = psigDY(i, j, mz) * (qsHY(i, j, mz) - qsrfHY(i, j)) * dt * grvinv
+ snohSL(i, j) = snohSL(i, j) + max(zero, dh_sno)
+ snobSL(i, j) = snobSL(i, j) + min(zero, dh_sno)
+ snowHY(i, j) = snowHY(i, j) + dh_sno
+ enddo
+ enddo
+#endif
+ return
+endsubroutine HYDadv_ver
diff --git a/MAR/code_mar/hydgen.f90 b/MAR/code_mar/hydgen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c624b99ec038fecce62b1a1fff6577bb6f27ff5f
--- /dev/null
+++ b/MAR/code_mar/hydgen.f90
@@ -0,0 +1,764 @@
+#include "MAR_pp.def"
+subroutine HYDgen
+ ! +------------------------------------------------------------------------+
+ ! | MAR HYDROLOGIC CYCLE 14-12-2022 MAR |
+ ! | subroutine HYDgen contains .main. of the EXPLICIT HYDROLOGICAL CYCLE |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT / OUTPUT: qvDY(mx,my,mz) : air specific humidity (kg/kg) |
+ ! | ^^^^^^^^^^^^^^^ qwHY(mx,my,mz) : cloud drops (kg/kg) |
+ ! | qrHY(mx,my,mz) : rain drops (kg/kg) |
+ ! | qiHY(mx,my,mz) : ice crystals concentration(kg/kg) |
+ ! | qsHY(mx,my,mz) : snow flakes (kg/kg) |
+ ! | rainHY(mx,my) : rain Precipitation (m) |
+ ! | snowHY(mx,my) : snow Precipitation (m w.e) |
+ ! | crysHY(mx,my) : ice Precipitation (m w.e) |
+ ! | hlatHY(mx,my,mz) : Latent Heat Release (K/s) |
+ ! | |
+ ! | OUTPUT: |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | REFER. : 1) Ntezimana, unpubl.thes.LLN, 115 pp, 1993 |
+ ! | ^^^^^^^^ 2) Lin et al. JCAM 22, 1065--1092, 1983 |
+ ! | (very similar, except that graupels are represented) |
+ ! | 3) Emde and Kahlig, An.Geo. 7, 405-- 414, 1989 |
+ ! | |
+ ! | # OPTIONS: #WH Additional Output (Each Process is detailed) |
+ ! | # ^^^^^^^^ #EW Additional Output (Energy and Water Conservation) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_hy
+ use mar_ca
+ use mar_te
+ use mar_tu
+ use mar_sl
+ use mar_wk
+ use mar_io
+ use mar_sv
+ use mar_tv
+#if(EW)
+ use mar_ew
+#endif
+ use mar_fi
+ use mar_ra
+ use marmagic
+#if(iso)
+ use mariso, only: wiso, niso, qvDY_iso
+#endif
+
+ implicit none
+ ! Local variables
+ ! ===============
+#if(iso)
+ real :: fac
+ ! iso_time : number of the output file increment
+ integer :: iso_time
+ ! iso_label : label of output increment
+ character*10 :: iso_label
+#endif
+ integer ioutIO(5)
+ real :: ccni2D(klon, klev)
+ real :: ccnw2D(klon, klev)
+ real :: cfra2D(klon, klev)
+ real :: crys2D(klon)
+ real :: dqi2D(klon, klev)
+ real :: dqw2D(klon, klev)
+ real :: ect_2D(klon, klev)
+ real :: enr01D(klon)
+ real :: enr11D(klon)
+ real :: enr21D(klon)
+ real :: gplv2D(klon, klev + 1)
+ real :: gpmi2D(klon, klev + 1)
+ real :: hlat2D(klon, klev)
+ integer :: jhlr2D(klon)
+ character(len=20) :: mphy2D(klon)
+ real :: pk2D(klon, klev)
+ real :: pkta2D(klon, klev)
+ real :: prec2D(klon)
+ real :: pst2D(klon)
+ real :: pst2Dn(klon)
+ real :: qg2D(klon, klev)
+ real :: qi2D(klon, klev)
+ real :: qr2D(klon, klev)
+ real :: qs2D(klon, klev)
+ ! qssbl2D : sublimated snow flakes (kg/kg)
+ real :: qssbl2D(klon, klev)
+ real :: qv2D(klon, klev)
+ real :: qvsi2D(klon, klev + 1)
+ real :: qvsw2D(klon, klev + 1)
+ real :: qw2D(klon, klev)
+ real :: rain2D(klon)
+ real :: rolv2D(klon, klev)
+ real :: snoh2D(klon)
+ real :: snow2D(klon)
+ real :: tair2D(klon, klev)
+ real :: tsrf2D(klon)
+ real :: TUkv2D(klon, klev)
+ real :: uair2D(klon, klev)
+ real :: vair2D(klon, klev)
+ real :: wair2D(klon, klev)
+ real :: wat01D(klon)
+ real :: wat11D(klon)
+ real :: wat21D(klon)
+ real :: watf1D(klon)
+ real :: snf2D(klon, klev)
+ real :: sbl2D(klon, klev)
+ ! dep2D : atm. snow condensation (m w.e.)
+ real :: dep2D(klon, klev)
+ real :: rnf2D(klon, klev)
+ real :: evp2D(klon, klev)
+ ! smt2D : atm. (integr) snow transport (kg/m)
+ real :: smt2D(klon, klev)
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! integer iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+ ! common /SISVAT_EV/ iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+#endif
+
+ integer i, j, k, m
+ character * 3 vecthy
+ integer klhyOK, io, io___1, io___5, iklon, itPhys, nthyd2
+ integer il_mmc, il__mm, i___mm, j___mm, il_mez, kk_pp
+#if(wH)
+ integer i_fvv(klon), j_fvv(klon), klfvv, i0fvv, j0fvv, k0fvv
+ common / DebuggHy / i_fvv, j_fvv, klfvv, i0fvv, j0fvv, k0fvv
+#endif
+
+ real qs99, hrelmx, erosmx, facLHR
+ real uq1, uq2, vq1, vq2, sq1, sq2
+ real uInFlw, uOutFl, pp, pkt0, ta_MAR
+ real vInFlw, vOutFl
+ real cloud_magic2, dthyd2, qqp
+
+ ! +--DATA
+ ! + ====
+
+ data i___mm/0/
+ data j___mm/0/
+ data qs99/0.99e+0/
+#if(wH)
+ i0fvv = 26 ! i ccordinate (detailled output)
+ j0fvv = 17 ! j ccordinate (detailled output)
+ k0fvv = 24 ! k ccordinate (detailled output)
+#endif
+
+ cloud_magic2 = 0.
+#if(EU)
+ cloud_magic2 = cloud_magic / (10.*real(ntHyd))
+#endif
+
+ ! +--Set UP Verification
+ ! + ===================
+#if(wH)
+ write(6, 6020) itexpe, jdarGE, mmarGE, iyrrGE, jhurGE, minuGE, jsecGE
+6020 format(/, 'Clouds Microphysics', 2i6, '-', i2, '-', i4, i6, 'h', i2, ':', i2)
+#endif
+ if(itexpe == 0) then
+ klhyOK = mx2 * my2
+ klhyOK = 1
+ if(klon /= klhyOK) then
+ if(klon > 1) then
+ vecthy = 'NON'
+ else
+ vecthy = ' '
+ endif
+ write(6, 6000) klon, klhyOK, vecthy
+6000 format(/, '++++++++ klon (mardim_mod.f90) =', i6, ' .NE.', i6, ' ++++++++++++++', &
+ /, '++++++++ NOT adapted to a ', a3, ' vectorized code ++++++++++++++', &
+ /, '++++++++ BAD SET UP of #hy or klon parameter ++++++++++++++', &
+ /, ' ==> !?%@&* Emergency EXIT in HYDgen')
+ stop
+ endif
+
+ ! +--Cloud Microphysics Initialization
+ ! + =================================
+ do j = 1, my
+ do i = 1, mx
+ rai0HY(i, j) = 0.
+ rainHY(i, j) = 0.
+ sno0HY(i, j) = 0.
+ sfa0HY(i, j) = 0.
+ snowHY(i, j) = 0.
+ crysHY(i, j) = 0.
+ enddo
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ccniHY(i, j, k) = 0.
+ qiHY(i, j, k) = 0.
+ qsHY(i, j, k) = 0.
+ qwHY(i, j, k) = 0.
+ qrHY(i, j, k) = 0.
+ snfHY(i, j, k) = 0.
+ sblHY(i, j, k) = 0.
+ depHY(i, j, k) = 0.
+ rnfHY(i, j, k) = 0.
+ evpHY(i, j, k) = 0.
+ smtHY(i, j, k) = 0.
+ qssblHY(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ !XF (not cumulated precip because in real*4) !!!!
+ if(iterun == 0) then
+ do i = 1, mx
+ do j = 1, my
+ do k = 1, mz
+ snfHY(i, j, k) = 0.
+ sblHY(i, j, k) = 0.
+ depHY(i, j, k) = 0.
+ rnfHY(i, j, k) = 0.
+ evpHY(i, j, k) = 0.
+ smtHY(i, j, k) = 0.
+ qssblHY(i, j, k) = 0.
+ enddo
+ rai0HY(i, j) = 0.
+ rainHY(i, j) = 0.
+ rainCA(i, j) = 0.
+ sno0HY(i, j) = 0.
+ sfa0HY(i, j) = 0.
+ snowHY(i, j) = 0.
+ snowCA(i, j) = 0.
+ crysHY(i, j) = 0.
+ runoTV(i, j) = 0.
+ draiTV(i, j) = 0.
+ evapTV(i, j) = 0.
+ enddo
+ enddo
+ endif
+ !XF
+
+ ! +--Cloud Microphysics OFF ==> Reset of the Air Relative Humidity
+ ! + =============================================================
+ if(jhaRUN < tim_HY) then
+ ! +...Hydrological cycle is inhibited until jhaRUN = tim_HY
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ tairDY(i, j, k) = pktaDY(i, j, k) * pkDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! + ******
+ call qsat3d
+ ! + ******
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+#if(iso)
+ fac = qvsiDY(i, j, k) * min(qs99, qvDY(i, j, k) / qvsiDY(i, j, k)) / qvDY(i, j, k)
+ do wiso = 1, niso
+ qvDY_iso(wiso, i, j, k) = fac * qvDY_iso(wiso, i, j, k)
+ enddo
+#endif
+ qvDY(i, j, k) = qvsiDY(i, j, k) * min(qs99, qvDY(i, j, k) / qvsiDY(i, j, k))
+ enddo
+ enddo
+ enddo
+ turnHY = .true.
+ endif
+
+ ! +--Decide to set ON Cloud Microphysics if Air Relative Humidity > Crit.
+ ! + ====================================================================
+ if(.not. turnHY) then
+#if(BS)
+ erosmx = -1.0
+#endif
+ ! + ******
+ call qsat3d
+ ! + ******
+ hrelmx = 0.0
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, mz
+ !cCA todo : check here if relevant ? why 2 lines ? why the second ?
+ hrelmx = max(hrelmx, qvDY(i, j, k) / qvsiDY(i, j, k))
+ hrelmx = max(hrelmx, qvDY(i, j, k) / qvswDY(i, j, k))
+#if(BS)
+ erosmx = max(erosmx, SLuusl(i, j, 1) - SaltSL(i, j))
+#endif
+ enddo
+ enddo
+ enddo
+ if(hrelmx > rhcrHY) turnHY = .true.
+#if(BS)
+ if(erosmx > 0.0) turnHY = .true.
+#endif
+ endif
+
+#if(iso)
+ iso_label = 'hydgen->1 '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+
+ ! +--Hydrological Cycle Initialization
+ ! + =================================
+ if(turnHY) then
+ ! +----From 3D to 2D arrays
+ ! + --------------------
+ do io = 1, 5
+ ioutIO(io) = igrdIO(io) + mx * (jgrdIO(io) - 1)
+ enddo
+#if(WH)
+ if(il__mm == 0) then
+ i___mm = imez
+ j___mm = jmez
+ il__mm = imez + (jmez - 1) * mx2
+ endif
+#endif
+#if(EW)
+ il_mez = imez + (jmez - 1) * mx2
+#endif
+ ! +
+ iklon = 0
+
+ !$OMP PARALLEL DO &
+ !$OMP private(i,j,k,iklon,facLHR,qqp,dtHyd2,ntHyd2, &
+ !$OMP io___1,io___5,il__mm,i___mm,j___mm,il_mez,kk_pp, &
+ !$OMP ccni2D,ccnw2D,cfra2D,crys2D, &
+ !$OMP dqi2D, dqw2D,ect_2D,enr01D, &
+ !$OMP enr11D,enr21D,gplv2D, &
+ !$OMP gpmi2D,hlat2D,jhlr2D,mphy2D, &
+ !$OMP pk2D,pkta2D,prec2D, pst2D, &
+ !$OMP pst2Dn, qg2D, qi2D, qr2D, &
+ !$OMP qs2D, qv2D,qvsi2D,qvsw2D, &
+ !$OMP qw2D,rain2D,rolv2D,snoh2D, &
+ !$OMP snow2D,tair2D,tsrf2D,TUkv2D, &
+ !$OMP uair2D,vair2D,wair2D,wat01D, &
+ !$OMP wat11D,wat21D,watf1D,qssbl2D, &
+ !$OMP snf2D,sbl2D,dep2D,rnf2D,evp2D,smt2D) &
+ !$OMP schedule(dynamic)
+
+ do j = 1, my
+ do i = 1, mx
+ 1234 continue
+ iklon = 1
+ qqp = 0
+
+ if(i > 1 .and. i < mx .and. j > 1 .and. j < my) then
+ do k = 1, klev
+ pk2D(iklon, k) = pkDY(i, j, k)
+ pkta2D(iklon, k) = pktaDY(i, j, k)
+ tair2D(iklon, k) = tairDY(i, j, k)
+ uair2D(iklon, k) = uairDY(i, j, k)
+ vair2D(iklon, k) = vairDY(i, j, k)
+ wair2D(iklon, k) = wairDY(i, j, k)*.01 + sqrt(2.*ect_TE(i, j, k) / 3.)
+ rolv2D(iklon, k) = rolvDY(i, j, k)
+#if(kk)
+ ! qv2D(iklon, k) = max(qvDY(i, j, k), epsq)
+#endif
+ qv2D(iklon, k) = &
+ max(qvDY(i, j, k), epsi)
+ qw2D(iklon, k) = qwHY(i, j, k)
+ qr2D(iklon, k) = qrHY(i, j, k)
+ qi2D(iklon, k) = qiHY(i, j, k)
+ qs2D(iklon, k) = max(qsHY(i, j, k), zero)
+ qqp = max(qqp,(qr2D(iklon, k) + qs2D(iklon, k)) / 2.)
+#if(qg)
+ qg2D(iklon, k) = qgHY(i, j, k)
+#endif
+ cfra2D(iklon, k) = cfraHY(i, j, k)
+ ccnw2D(iklon, k) = ccnwHY(i, j, k)
+ ccni2D(iklon, k) = ccniHY(i, j, k)
+ dqi2D(iklon, k) = 0.
+ dqw2D(iklon, k) = 0.
+ hlat2D(iklon, k) = hlatHY(i, j, k)
+ ect_2D(iklon, k) = ect_TE(i, j, k)
+ TUkv2D(iklon, k) = TUkvh(i, j, k)
+ snf2D(iklon, k) = snfHY(i, j, k)
+ sbl2D(iklon, k) = sblHY(i, j, k)
+ dep2D(iklon, k) = depHY(i, j, k)
+ rnf2D(iklon, k) = rnfHY(i, j, k)
+ evp2D(iklon, k) = evpHY(i, j, k)
+ smt2D(iklon, k) = smtHY(i, j, k)
+ qssbl2D(iklon, k) = qssblHY(i, j, k)
+ enddo
+
+ do k = max(1, mzhyd - 1), klev + 1
+ gplv2D(iklon, k) = gplvDY(i, j, k)
+ gpmi2D(iklon, k) = gpmiDY(i, j, k)
+ qvsw2D(iklon, k) = qvswDY(i, j, k)
+ qvsi2D(iklon, k) = qvsiDY(i, j, k)
+ enddo
+
+ kk_pp = klev / 2
+ do k = klev, klev / 2, -1
+ if(gplvDY(i, j, k) * grvinv - sh(i, j) < 100) kk_pp = k
+ enddo
+
+ ! do k = max(1, mzhyd - 1), klev
+ ! if(qvDY(i, j, k)>=qvswDY(i, j, k) .and. tairDY(i, j, k)>=273.15) qqp = 1
+ ! if(qvDY(i, j, k)>=qvsiDY(i, j, k) .and. tairDY(i, j, k)<=273.15) qqp = 1
+ ! if(qqp>2 * eps9) goto 777
+ ! end do
+ ! 777 continue
+
+ pst2D(iklon) = pstDY(i, j)
+ pst2Dn(iklon) = pstDYn(i, j)
+ rain2D(iklon) = rainHY(i, j)
+ snow2D(iklon) = snowHY(i, j)
+ crys2D(iklon) = crysHY(i, j)
+ prec2D(iklon) = precSL(i, j)
+ snoh2D(iklon) = snohSL(i, j)
+ tsrf2D(iklon) = TairSL(i, j)
+#if(EW)
+ wat01D(iklon) = wat0EW(i, j)
+ wat11D(iklon) = wat1EW(i, j)
+ wat21D(iklon) = wat2EW(i, j)
+ watf1D(iklon) = watfEW(i, j)
+ enr01D(iklon) = enr0EW(i, j)
+ enr11D(iklon) = enr1EW(i, j)
+ enr21D(iklon) = enr2EW(i, j)
+ mphy2D(iklon) = mphyEW(i, j)
+#endif
+ jhlr2D(iklon) = jhlrGE(i, j)
+
+ ! +----Call Cloud Microphysics, in case of NO vectorization
+ ! + ----------------------------------------------------
+
+ io___1 = 0
+ io___5 = 0
+ do io = 1, 5
+ if(ioutIO(io) == iklon) then
+ io___1 = io
+ io___5 = io
+ endif
+ enddo
+ if(i == i___mm .and. j == j___mm) then
+ il__mm = 1
+ else
+ il__mm = 0
+ endif
+ if(i == imez .and. j == jmez) then
+ il_mez = 1
+ else
+ il_mez = 0
+ endif
+
+ dtHyd2 = dt / real(ntHyd)
+ ntHyd2 = ntHyd
+
+ if(qqp <= epsi * 100.) then
+ ntHyd2 = min(2, ntHyd)
+ dtHyd2 = dt / real(ntHyd2)
+ endif
+ if(qqp <= epsi * 10. .or. i <= 10 .or. j <= 10 .or. i >= mx - 9 .or. j >= my - 9) then
+ ntHyd2 = min(1, ntHyd)
+ dtHyd2 = dt / real(ntHyd2)
+ endif
+ do itPhys = 1, max(1, ntHyd2)
+ do k = mzhyd, klev
+ qw2D(iklon, k) = qw2D(iklon, k) + cloud_magic2 * qr2D(iklon, k)
+ qr2D(iklon, k) = qr2D(iklon, k) * (1.-cloud_magic2)
+ if(qi2D(iklon, k) < qs2D(iklon, k) * 10e-3 .and. &
+ gplvDY(i, j, k) * grvinv - sh(i, j) > 200.) then
+ qi2D(iklon, k) = qi2D(iklon, k) + cloud_magic2 * qs2D(iklon, k)
+ qs2D(iklon, k) = qs2D(iklon, k) * (1.-cloud_magic2)
+ endif
+ enddo
+ ! + ***********
+ call HYDmic(io___1, io___5, ioutIO, &
+ il__mm, i___mm, j___mm, il_mez, kk_pp, &
+ ccni2D, ccnw2D, cfra2D, crys2D, &
+ dqi2D, dqw2D, ect_2D, enr01D, &
+ enr11D, enr21D, gplv2D, &
+ gpmi2D, hlat2D, jhlr2D, mphy2D, &
+ pk2D, pkta2D, prec2D, pst2D, &
+ pst2Dn, qg2D, qi2D, qr2D, &
+ qs2D, qv2D, qvsi2D, qvsw2D, &
+ qw2D, rain2D, rolv2D, snoh2D, &
+ snow2D, tair2D, tsrf2D, TUkv2D, &
+ uair2D, vair2D, wair2D, wat01D, &
+ wat11D, wat21D, watf1D, dtHyd2, &
+ snf2D, sbl2D, dep2D, rnf2D, evp2D, &
+ smt2D, qssbl2D, itPhys, ntHyd2)
+ ! + ***********
+ enddo
+
+ do k = 1, klev
+ if(isnan(tair2D(iklon, k)).or.isnan(qs2D(iklon, k)).or.isnan(qi2D(iklon, k)))then
+ print *,"NaN in Hydmic at pixel (i,j,k):",i,j,k
+ goto 1234
+ endif
+ enddo
+
+ ! +----From 2D to 3D arrays, in case of NO vectorization
+ ! + ----------------------------------------------------
+
+ do k = 1, klev
+ pktaDY(i, j, k) = pkta2D(iklon, k)
+ tairDY(i, j, k) = tair2D(iklon, k)
+ rolvDY(i, j, k) = rolv2D(iklon, k)
+ qvsiDY(i, j, k) = qvsi2D(iklon, k)
+ qvswDY(i, j, k) = qvsw2D(iklon, k)
+ qvDY(i, j, k) = qv2D(iklon, k)
+ qwHY(i, j, k) = qw2D(iklon, k)
+ qrHY(i, j, k) = qr2D(iklon, k)
+ qiHY(i, j, k) = qi2D(iklon, k)
+ qsHY(i, j, k) = qs2D(iklon, k)
+ snfHY(i, j, k) = snf2D(iklon, k)
+ sblHY(i, j, k) = sbl2D(iklon, k)
+ depHY(i, j, k) = dep2D(iklon, k)
+ rnfHY(i, j, k) = rnf2D(iklon, k)
+ evpHY(i, j, k) = evp2D(iklon, k)
+#if(qg)
+ qgHY(i, j, k) = qg2D(iklon, k)
+#endif
+ cfraHY(i, j, k) = cfra2D(iklon, k)
+ ccnwHY(i, j, k) = ccnw2D(iklon, k)
+ ccniHY(i, j, k) = ccni2D(iklon, k)
+ dqiHY(i, j, k) = dqi2D(iklon, k) * dsigm1(k) * pstDYn(i, j)
+ dqwHY(i, j, k) = dqw2D(iklon, k) * dsigm1(k) * pstDYn(i, j)
+ hlatHY(i, j, k) = hlat2D(iklon, k)
+ smthy(i, j, k) = smt2D(iklon, k)
+ qssblHY(i, j, k) = qssbl2D(iklon, k)
+ enddo
+
+ rainHY(i, j) = rain2D(iklon)
+ snowHY(i, j) = snow2D(iklon)
+ crysHY(i, j) = crys2D(iklon)
+ precSL(i, j) = prec2D(iklon)
+ snohSL(i, j) = snoh2D(iklon)
+#if(ew)
+ wat0EW(i, j) = wat01D(iklon)
+ wat1EW(i, j) = wat11D(iklon)
+ wat2EW(i, j) = wat21D(iklon)
+ watfEW(i, j) = watf1D(iklon)
+ enr0EW(i, j) = enr01D(iklon)
+ enr1EW(i, j) = enr11D(iklon)
+ enr2EW(i, j) = enr21D(iklon)
+ mphyEW(i, j) = mphy2D(iklon)
+#endif
+
+ ! +----Call Cloud Microphysics, in case of vectorization
+ ! + ----------------------------------------------------
+#if(hy)
+ ! if (klon.gt.1) then
+#endif
+ ! io___1 = 1
+ ! io___5 = 5
+#if(WH)
+ ! + ***********
+ ! call HYDmic(io___1,io___5,il__mm,i___mm,j___mm,il_mez)
+ ! + ***********
+ !
+ ! il_mmc = il__mm
+ ! j___mm = 0
+ ! 1000 continue
+ ! il_mmc = il_mmc-(my2-jp11+1)
+ ! j___mm = j___mm + 1
+ ! if (il_mmc.gt.0) go to 1000
+ ! i___mm = il_mmc+(my2-jp11+1) + ip11
+#endif
+
+ ! +----From 2D to 3D arrays, in case of vectorization
+ ! + ----------------------------------------------------
+ ! iklon = 0
+ ! do j = jp11,my1
+ ! do i = ip11,mx1
+ ! iklon = iklon + 1
+ ! do k=1,klev
+ ! pktaDY(i,j,k)=pkta2D(iklon,k)
+ ! tairDY(i,j,k)=tair2D(iklon,k)
+ ! rolvDY(i,j,k)=rolv2D(iklon,k)
+ ! qvsiDY(i,j,k)=qvsi2D(iklon,k)
+ ! qvswDY(i,j,k)=qvsw2D(iklon,k)
+ ! qvDY(i,j,k)= qv2D(iklon,k)
+ ! qwHY(i,j,k)= qw2D(iklon,k)
+ ! qrHY(i,j,k)= qr2D(iklon,k)
+ ! qiHY(i,j,k)= qi2D(iklon,k)
+ ! qsHY(i,j,k)= qs2D(iklon,k)
+ ! snfHY(i,j,k)= snf2D(iklon,k)
+ ! smthy(i,j,k)= smt2D(iklon,k)
+ ! sblHY(i,j,k)= sbl2D(iklon,k)
+ ! rnfHY(i,j,k)= rnf2D(iklon,k)
+ ! evpHY(i,j,k)= evp2D(iklon,k)
+ !#if(qg)
+ ! qgHY(i,j,k)= qg2D(iklon,k)
+ !#endif
+ ! cfraHY(i,j,k)=cfra2D(iklon,k)
+ ! ccnwHY(i,j,k)=ccnw2D(iklon,k)
+ ! ccniHY(i,j,k)=ccni2D(iklon,k)
+ ! dqiHY(i,j,k)= dqi2D(iklon,k)*dsigm1(k)*pstDYn(i,j)
+ ! dqwHY(i,j,k)= dqw2D(iklon,k)*dsigm1(k)*pstDYn(i,j)
+ ! hlatHY(i,j,k)=hlat2D(iklon,k)
+ ! end do
+ ! rainHY(i,j) =rain2D(iklon)
+ ! snowHY(i,j) =snow2D(iklon)
+ ! crysHY(i,j) =crys2D(iklon)
+ ! precSL(i,j) =prec2D(iklon)
+ ! snohSL(i,j) =snoh2D(iklon)
+#if(EW)
+ ! wat0EW(i, j) = wat01D(iklon)
+ ! wat1EW(i, j) = wat11D(iklon)
+ ! wat2EW(i, j) = wat21D(iklon)
+ ! watfEW(i, j) = watf1D(iklon)
+ ! enr0EW(i, j) = enr01D(iklon)
+ ! enr1EW(i, j) = enr11D(iklon)
+ ! enr2EW(i, j) = enr21D(iklon)
+ ! mphyEW(i, j) = mphy2D(iklon)
+#endif
+ ! end do
+ ! end do
+#if(hy)
+ ! end if
+#endif
+ ! +--Isotopes Proxies: Diagnostics
+ ! + =============================
+ WKxy1(i, j) = 0.
+ WKxy2(i, j) = 0.
+ WKxy3(i, j) = 0.
+ WKxy4(i, j) = 0.
+ WKxy5(i, j) = 0.
+ WKxy6(i, j) = 0.
+ do k = 2, klev
+ WKxy1(i, j) = WKxy1(i, j) &
+ + dsigm1(k) * max(hlatHY(i, j, k), 0.)
+ WKxy2(i, j) = WKxy2(i, j) &
+ - dsigm1(k) * min(hlatHY(i, j, k), 0.)
+ WKxy3(i, j) = WKxy3(i, j) &
+ + dsigm1(k) * max(hlatHY(i, j, k), 0.) * tairDY(i, j, k)
+ WKxy4(i, j) = WKxy4(i, j) &
+ - dsigm1(k) * min(hlatHY(i, j, k), 0.) * tairDY(i, j, k)
+ WKxy5(i, j) = WKxy5(i, j) &
+ + dsigm1(k) * max(hlatHY(i, j, k), 0.) * gplvDY(i, j, k)
+ WKxy6(i, j) = WKxy6(i, j) &
+ - dsigm1(k) * min(hlatHY(i, j, k), 0.) * gplvDY(i, j, k)
+ enddo
+ facLHR = (cp / Ls_H2O) * pstDYn(i, j) * 1.e3 * grvinv * dt
+ Hcd_HY(i, j) = Hcd_HY(i, j) + WKxy1(i, j) * facLHR
+ Hsb_HY(i, j) = Hsb_HY(i, j) + WKxy2(i, j) * facLHR
+ Tcd_HY(i, j) = Tcd_HY(i, j) + WKxy3(i, j) * facLHR
+ Tsb_HY(i, j) = Tsb_HY(i, j) + WKxy4(i, j) * facLHR
+ zcd_HY(i, j) = zcd_HY(i, j) + WKxy5(i, j) * facLHR
+ zsb_HY(i, j) = zsb_HY(i, j) + WKxy6(i, j) * facLHR
+ endif
+
+ icntHY = icntHY + 1
+
+ ! +--Hydrological Cycle Lateral Boundary Conditions
+ ! + ==============================================
+
+ if(i == 1) then
+ do k = mzhyd, mz
+ WKxyz1(1, j, k) = max(0., sign(1., uairDY(1, j, k))) ! u_In_Flow
+ WKxyz2(1, j, k) = 1.-WKxyz1(1, j, k) ! u_OutFlow
+ WKxyz3(1, j, k) = (sigma(k) * pstDY(1, j) + ptopDY)**cap ! pp
+ WKxyz4(1, j, k) = pktaDY(1, j, k)
+
+ WKxyz1(mx, j, k) = max(0., sign(1., uairDY(mx, j, k)))
+ WKxyz2(mx, j, k) = 1.-WKxyz1(mx, j, k)
+ WKxyz3(mx, j, k) = (sigma(k) * pstDY(mx, j) + ptopDY)**cap
+ WKxyz4(mx, j, k) = pktaDY(mx, j, k)
+ enddo
+
+ do k = mzhyd, mz
+ qwHY(1, j, k) = qwHY(1, j, k) * WKxyz2(1, j, k)
+ qiHY(1, j, k) = qiHY(1, j, k) * WKxyz2(1, j, k)
+ qrHY(1, j, k) = qrHY(1, j, k) * WKxyz2(1, j, k)
+ qsHY(1, j, k) = qsHY(1, j, k) * WKxyz2(1, j, k)
+ WKxyz5(1, j, k) = tairDY(1, j, k) * WKxyz2(1, j, k)
+
+ qwHY(mx, j, k) = qwHY(mx, j, k) * WKxyz1(mx, j, k)
+ qiHY(mx, j, k) = qiHY(mx, j, k) * WKxyz1(mx, j, k)
+ qrHY(mx, j, k) = qrHY(mx, j, k) * WKxyz1(mx, j, k)
+ qsHY(mx, j, k) = qsHY(mx, j, k) * WKxyz1(mx, j, k)
+ WKxyz5(mx, j, k) = tairDY(mx, j, k) * WKxyz1(mx, j, k)
+ enddo
+
+ do k = mzhyd, mz
+ pktaDY(1, j, k) = pktaDY(1, j, k) * WKxyz1(1, j, k) &
+ + WKxyz5(1, j, k) / WKxyz3(1, j, k)
+
+ pktaDY(mx, j, k) = pktaDY(mx, j, k) * WKxyz2(mx, j, k) &
+ + WKxyz5(mx, j, k) / WKxyz3(mx, j, k)
+ enddo
+
+ do k = mzhyd, mz
+ hlatHY(1, j, k) = WKxyz5(1, j, k) &
+ * (1.0 - WKxyz4(1, j, k) / pktaDY(1, j, k)) / dt
+
+ hlatHY(mx, j, k) = WKxyz5(mx, j, k) &
+ * (1.0 - WKxyz4(mx, j, k) / pktaDY(mx, j, k)) / dt
+ enddo
+ endif
+
+ if(j == 1) then
+ do k = mzhyd, mz
+ WKxyz1(i, 1, k) = max(0., sign(1., vairDY(i, 1, k))) ! v_In_Flow
+ WKxyz2(i, 1, k) = 1.-WKxyz1(i, 1, k) ! v_OutFlow
+ WKxyz3(i, 1, k) = (sigma(k) * pstDY(i, 1) + ptopDY)**cap ! pp
+ WKxyz4(i, 1, k) = pktaDY(i, 1, k)
+
+ WKxyz1(i, my, k) = max(0., sign(1., vairDY(i, my, k)))
+ WKxyz2(i, my, k) = 1.-WKxyz1(i, my, k)
+ WKxyz3(i, my, k) = (sigma(k) * pstDY(i, my) + ptopDY)**cap
+ WKxyz4(i, my, k) = pktaDY(i, my, k)
+ enddo
+
+ do k = mzhyd, mz
+ qwHY(i, 1, k) = qwHY(i, 1, k) * WKxyz2(i, 1, k)
+ qiHY(i, 1, k) = qiHY(i, 1, k) * WKxyz2(i, 1, k)
+ qrHY(i, 1, k) = qrHY(i, 1, k) * WKxyz2(i, 1, k)
+ qsHY(i, 1, k) = qsHY(i, 1, k) * WKxyz2(i, 1, k)
+ WKxyz5(i, 1, k) = tairDY(i, 1, k) * WKxyz2(i, 1, k)
+
+ qwHY(i, my, k) = qwHY(i, my, k) * WKxyz1(i, my, k)
+ qiHY(i, my, k) = qiHY(i, my, k) * WKxyz1(i, my, k)
+ qrHY(i, my, k) = qrHY(i, my, k) * WKxyz1(i, my, k)
+ qsHY(i, my, k) = qsHY(i, my, k) * WKxyz1(i, my, k)
+ WKxyz5(i, my, k) = tairDY(i, my, k) * WKxyz1(i, my, k)
+ enddo
+
+ do k = mzhyd, mz
+ pktaDY(i, 1, k) = pktaDY(i, 1, k) * WKxyz1(i, 1, k) &
+ + WKxyz5(i, 1, k) / WKxyz3(i, 1, k)
+
+ pktaDY(i, my, k) = pktaDY(i, my, k) * WKxyz2(i, my, k) &
+ + WKxyz5(i, my, k) / WKxyz3(i, my, k)
+ enddo
+
+ do k = mzhyd, mz
+ hlatHY(i, 1, k) = WKxyz5(i, 1, k) &
+ * (1.0 - WKxyz4(i, 1, k) / pktaDY(i, 1, k)) / dt
+
+ hlatHY(i, my, k) = WKxyz5(i, my, k) &
+ * (1.0 - WKxyz4(i, my, k) / pktaDY(i, my, k)) / dt
+ enddo
+ endif
+ WKxy1(i, j) = 0.
+ WKxy2(i, j) = 0.
+ WKxy3(i, j) = 0.
+ WKxy4(i, j) = 0.
+ WKxy5(i, j) = 0.
+ WKxy6(i, j) = 0.
+
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+ endif
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! if (lSV_v1>0 .and. lSV_v1<=2) then
+ ! write(6, 6010) ((qsHY(iSV_v1, jSV_v1, k) * 1.e3), k = mz, mz - 4, -1)
+ ! 6010 format(10x, 'After HYDmic : q [g/kg] =', 5f9.6)
+ ! end if
+#endif
+ return
+endsubroutine HYDgen
diff --git a/MAR/code_mar/hydmic.f90 b/MAR/code_mar/hydmic.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e232f9b61dee9c60a988fd974310ecd0691672e7
--- /dev/null
+++ b/MAR/code_mar/hydmic.f90
@@ -0,0 +1,4146 @@
+#include "MAR_pp.def"
+subroutine HYDmic(io1, io5, ioutIO, &
+ ilmm, imm, jmm, ilmez, kk_pp, &
+ ccni2D, ccnw2D, cfra2D, crys2D, &
+ dqi2D, dqw2D, ect_2D, enr01D, &
+ enr11D, enr21D, gplv2D, &
+ gpmi2D, hlat2D, jhlr2D, mphy2D, &
+ pk2D, pkta2D, prec2D, pst2D, &
+ pst2Dn, qg2D, qi2D, qr2D, &
+ qs2D, qv2D, qvsi2D, qvsw2D, &
+ qw2D, rain2D, rolv2D, snoh2D, &
+ snow2D, tair2D, tsrf2D, TUkv2D, &
+ uair2D, vair2D, wair2D, wat01D, &
+ wat11D, wat21D, watf1D, dtHyd2, &
+ snf2D, sbl2D, dep2D, rnf2D, evp2D, &
+ smt2D, qssbl2D, itPhys, ntHyd2)
+ !------------------------------------------------------------------------+
+ ! MAR HYDROLOGIC CYCLE 15-dec-2022 MAR |
+ ! subroutine HYDmic computes Cloud Microphysical Processes |
+ ! |
+ !------------------------------------------------------------------------+
+ ! |
+ ! INPUT / OUTPUT: qv2D(klon,klev): air specific humidity (kg/kg) |
+ ! ^^^^^^^^^^^^^^ qw2D(klon,klev): cloud drops (kg/kg) |
+ ! qr2D(klon,klev): rain drops (kg/kg) |
+ ! qi2D(klon,klev): ice crystals concentration(kg/kg) |
+ ! qs2D(klon,klev): snow flakes (kg/kg) |
+ ! qssbl2D(klon,klev): sublimated snow flakes (kg/kg) |
+ ! (to be added) qg2D(klon,klev): graupels (kg/kg) |
+ ! ccnw2D(klon,klev): cloud droplets number (Nb/m3) |
+ ! ccni2D(klon,klev): ice crystals number (Nb/m3) |
+ ! |
+ ! cfra2D(klon,klev): cloud fraction |
+ ! |
+ ! rain2D(klon) : rain Precipitation (m w.e.) |
+ ! snow2D(klon) : snow Precipitation (m w.e.) |
+ ! crys2D(klon) : ice Precipitation (m w.e.) |
+ ! |
+ ! Precipitation and sublimation in the atmosphere |
+ ! snf2D(klon,klev): atm. snow precipitation (m w.e.) |
+ ! sbl2D(klon,klev): atm. snow sublimation (m w.e.) |
+ ! dep2D(klon,klev): atm. snow condensation (m w.e.) |
+ ! rnf2D(klon,klev): atm. rain precipitation (m w.e.) |
+ ! evp2D(klon,klev): atm. rain evaporation (m w.e.) |
+ ! smt2D(klon,klev): atm. (integr) snow transport (kg/m) |
+ ! |
+ ! hlat2D(klon,klev): Latent Heat Release (K/s) |
+ ! dqi2D(klon,klev): Ice Water Formation (kg/kg) |
+ ! dqw2D(klon,klev): Liquid Water Formation (kg/kg) |
+ ! qvsi2D(klon,klev+1): Saturation Specific Humid.(kg/kg) |
+ ! qvsw2D(klon,klev+1): Saturation Specific Humid.(kg/kg) |
+ ! |
+ ! REFER. : 1) Ntezimana, unpubl.thes.LLN, 115 pp, 1993 |
+ ! ^^^^^ 2) Lin et al. JCAM 22, 1065--1092, 1983 |
+ ! (very similar, except that graupels are represented) |
+ ! 3) Emde and Kahlig, Annal.Geophys. 7, 405-- 414, 1989 |
+ ! 4) Levkov et al., Contr.Atm.Phys. 65, 35-- 57, 1992 |
+ ! 5) Meyers et al., JAM 31, 708-- 731, 1992 |
+ ! (Primary Ice-Nucleation Parameterization) |
+ ! 6) Delobbe and Gallee, BLM 89, 75-- 107 1998 |
+ ! (Partial Condensation Scheme) |
+ ! |
+ ! CAUTION: Partial Condensation Scheme NOT validated |
+ ! ^^^^^^^ for SCu -- Cu Transition |
+ ! erf fonction is erroneous on HP |
+ ! |
+ !# OPTIONS: #HM Hallet-Mossop Theory (for Convective Updraft) |
+ !# ^^^^^^^ #hm idem (non vectorized code) |
+ !# !#qf Cloud Droplets Heterogeneous Freezing (not included) |
+ !# !#qg Graupel Conservation Equation (to include) |
+ !# #hb Snow particles distrib. parameter cnos set to BS value |
+ !# #hs Emde & Kahlig Homogeneous Sublimation (not in Levkov) |
+ !# !#pp Emde & Kahlig Ice Crystal Deposition (not included) |
+ ! |
+ !# #VW Duynkerke et al. 1995, JAS 52, p.2763 Dropplets Fall |
+ !# #LI Lin et al (1983,JCAM 22, p.1076(50) Autoconv. Scheme |
+ !# #LO Liou and Ou (1989, JGR 94, p.8599) Autoconv. Scheme |
+ ! |
+ !# #up Snow Particles: Unrimed Side Planes |
+ !# #ur Snow Particles: Aggregates of unrimed radiat. assembl. |
+ ! |
+ !# DEBUG: #WH Additional Output (Each Process is detailed) |
+ !# ^^^^^ #WQ FULL Output (Each Process is detailed) |
+ !# #EW Additional Output (Energy and Water Conservation) |
+ ! |
+ ! REMARK : the sign '~' indicates that reference must be verified |
+ ! ^^^^^^^^ |
+ !------------------------------------------------------------------------+
+
+ use mardim
+ use marctr
+ use marphy
+ use margrd
+ use mar_ge
+ use mar_io
+ use mar_dy
+ use mar_hy
+ use marmagic
+#if(EW)
+ use mar_ew
+#endif
+
+ implicit none
+
+ ! Input - Output
+ ! ==============
+ ! in
+ ! --
+ integer, intent(in) :: io1
+ integer, intent(in) :: io5
+ integer, intent(in) :: ioutIO(5)
+ integer, intent(in) :: imm
+ integer, intent(in) :: jmm
+ integer, intent(in) :: ilmez
+ integer, intent(in) :: kk_pp
+ integer, intent(in) :: itPhys
+ integer, intent(in) :: ntHyd2
+ real, intent(in) :: dtHyd2
+ ! inout
+ ! ----
+ integer, intent(inout) :: ilmm
+ real, intent(inout) :: ccni2D(klon, klev)
+ real, intent(inout) :: ccnw2D(klon, klev)
+ real, intent(inout) :: cfra2D(klon, klev)
+ real, intent(inout) :: crys2D(klon)
+ real, intent(inout) :: dqi2D(klon, klev)
+ real, intent(inout) :: dqw2D(klon, klev)
+ real, intent(inout) :: ect_2D(klon, klev)
+ real, intent(inout) :: enr01D(klon)
+ real, intent(inout) :: enr11D(klon)
+ real, intent(inout) :: enr21D(klon)
+ real, intent(inout) :: gplv2D(klon, klev + 1)
+ real, intent(inout) :: gpmi2D(klon, klev + 1)
+ real, intent(inout) :: hlat2D(klon, klev)
+ integer, intent(inout) :: jhlr2D(klon)
+ character(len = 20), intent(inout) :: mphy2D(klon)
+ real, intent(inout) :: pk2D(klon, klev)
+ real, intent(inout) :: pkta2D(klon, klev)
+ real, intent(inout) :: prec2D(klon)
+ real, intent(inout) :: pst2D(klon)
+ real, intent(inout) :: pst2Dn(klon)
+ real, intent(inout) :: qg2D(klon, klev)
+ real, intent(inout) :: qi2D(klon, klev)
+ real, intent(inout) :: qr2D(klon, klev)
+ real, intent(inout) :: qs2D(klon, klev)
+ real, intent(inout) :: qv2D(klon, klev)
+ real, intent(inout) :: qvsi2D(klon, klev + 1)
+ real, intent(inout) :: qvsw2D(klon, klev + 1)
+ real, intent(inout) :: qw2D(klon, klev)
+ real, intent(inout) :: rain2D(klon)
+ real, intent(inout) :: rolv2D(klon, klev)
+ real, intent(inout) :: snoh2D(klon)
+ real, intent(inout) :: snow2D(klon)
+ real, intent(inout) :: tair2D(klon, klev)
+ real, intent(inout) :: tsrf2D(klon)
+ real, intent(inout) :: TUkv2D(klon, klev)
+ real, intent(inout) :: uair2D(klon, klev)
+ real, intent(inout) :: vair2D(klon, klev)
+ real, intent(inout) :: wair2D(klon, klev)
+ real, intent(inout) :: wat01D(klon)
+ real, intent(inout) :: wat11D(klon)
+ real, intent(inout) :: wat21D(klon)
+ real, intent(inout) :: watf1D(klon)
+ real, intent(inout) :: snf2D(klon, klev)
+ real, intent(inout) :: sbl2D(klon, klev)
+ real, intent(inout) :: dep2D(klon, klev)
+ real, intent(inout) :: qssbl2D(klon, klev)
+ real, intent(inout) :: rnf2D(klon, klev)
+ real, intent(inout) :: evp2D(klon, klev)
+ real, intent(inout) :: smt2D(klon, klev)
+
+#if(wH)
+ ! Debug Variables
+ ! ~~~~~~~~~~~~~~~
+ integer i_fvv(klon), j_fvv(klon), klfvv, i0fvv, j0fvv, k0fvv
+ common / DebuggHy / i_fvv, j_fvv, klfvv, i0fvv, j0fvv, k0fvv
+ character * 70 debugH
+ character * 10 proc_1, proc_2, proc_3, proc_4
+ real procv1, procv2, procv3, procv4
+ integer kv, nl
+ real debugV(16, klev)
+#endif
+
+ ! Local Variables
+ ! ================
+
+ integer k, m
+ integer il, kl, itc, itmx, it, ii, io, ilmmi
+
+ ! Work variables
+ real :: W2xyz1(klon, klev)
+ real :: W2xyz2(klon, klev)
+ real :: W2xyz3(klon, klev)
+ real :: W2xyz4(klon, klev)
+ real :: W2xyz5(klon, klev + 1)
+ real :: W2xyz6(klon, klev + 1)
+ real :: W2xyz7(klon, klev + 1)
+ real :: W2xyz8(klon, klev + 1)
+ real :: W2xyz9(klon, klev)
+ real :: W2xyz0(klon, klev)
+
+ real :: qrevp2D(klon, klev)
+ real :: qssub2D(klon, klev)
+ real :: hsub2D(klon, klev)
+ real :: vs2D(klon, klev)
+
+ real argerf, erf, xt
+ real signQw, signQr, signQi, signQs, signCi, signVR, &
+ signVS, signHN, Qw0_OK, Qr0_OK, Qi0_OK, Qs0_OK, &
+ Qi0qOK, Ci0cOK, Ci0_OK, vr__OK, vs__OK, qHoNuc, &
+ qwOK, dpv, dqv, qHeNu1, qHeNu2, qHeNu3, qHeNuc, &
+ qicnd1, qisign, qi1_OK, qicnd2, qicnd, qBerge, &
+ a1, a2, am0, qidep, qvdfci, qSubl1, qSubl2, qSubli, &
+ demde, sat, ab1, ab2, amf, pisub, qisub, qMelt1, &
+ qMelt2, qMelt, qxmlt, qimlt, cimlt, qt, tl, pa_hPa, &
+ es_hPa, qsl, dqt, wqt, ww, coefC2, sig2rh, sigqt, &
+ err, alpha, t1, t2, signFR, cfraOK, SCuLim, &
+ qw_new, dqw, signdq, fac_qv, updatw, dpw, signAU, &
+ AutoOK, signFC, ClouOK, praut, qraut, signCC, qiOK, &
+ qid, a1saut, c1saut, xtsaut, qsaut, cnsaut, ex1, psaut, &
+ sign_W, WbyR_w, sign_R, WbyR_r, WbyROK, pracw, &
+ qracw, WbyS_w, sign_S, WbyS_s, WbySOK, qsacw, &
+ sign_T, Fact_R, SnoA, sign_C, CbyS_c, CbyS_T, &
+ CbySOK, efc, psaci, qsaci, cnsaci, CbyR_c, CbyR_r, &
+ CbyR_T, CbyROK, praci, qraci, CbyS_s, cnraci, &
+ piacr, qiacr, qsacr, RbyS_r, RbyS_s, RbySOK, flR, &
+ SbyR_r, SbyR_s, SbyROK, flS, pracs, qracs, qsacrS, &
+ qracsS, Evap_r, EvapOK, sr, sign_Q, Evap_q, &
+ qsacrR, almr, ab, prevp, qrevp, Evap_s, alms, si, &
+ pssub, qssub, dqamx, Depo_s, SnoM_s, SnoM_T, &
+ SnoMOK, qsmlt, xCoef, ACoef, BCoef, Tc, &
+ Freezr, FreezT, FrerOK, psfr, akps, psmlt, &
+ qsfr, Sedi_c, Sedicc, SediOK, vrmx, vsmx, vimx, &
+ dzmn, xtmn, dwat, dsno, qcloud, pp, pkt0, vmmx, vmmi, &
+ connw, qwclou, dmed0, dmedv, dmede, dmed5, waterb, &
+ dmed, dmed2, dw0, dw4, rwbar, signHV, heavi, vwmx
+
+ real dqi, dqi1, dqi2, dqi3
+ real relhum, argexp, qvs_wi
+ real ratio_rfsf, ratio_temp, ratio_prec
+
+ real vi(klon, klev)
+#if(VW)
+ real vw(klon, klev)
+#endif
+ real vr(klon, klev)
+ real vs(klon, klev)
+#if(qg)
+ real vh(klon, klev)
+#endif
+ real psacw(klon, klev), psacr(klon, klev)
+
+#if(WH)
+ real wihm1(klev), wihm2(klev), wicnd(klev)
+ real widep(klev), wisub(klev), wimlt(klev)
+ real wwevp(klev)
+ real wraut(klev), wsaut(klev)
+ real wracw(klev), wsacw(klev)
+ real wsaci(klev), wraci(klev), wiacr(klev)
+ real wsacr(klev), wracs(klev), wrevp(klev)
+ real wssub(klev), wsmlt(klev), wsfre(klev)
+ real qiold(klev), qwold(klev)
+#endif
+
+ ! rad_ww: Droplet Radius, Meyers et al. (1992), JAM
+ real rad_ww
+
+#if(HM)
+ ! Levkov et al. (1992) CAM
+ real SplinJ, SplinP
+#endif
+
+ ! DATA
+ ! ====
+
+ logical, parameter :: Meyers = .true.
+ logical, parameter :: LevkovAUTO = .true.
+ ! LevkovAUTX = .true. => Levkov parameterization Bergeron Processes
+ ! LevkovAUTX = .false. => Emde&Kahlig parameterization Bergeron Processes
+ logical, parameter :: LevkovAUTX = .true.
+
+ logical, parameter :: EmdeKa = .false.
+ ! fracSC: SCu Fractional Cloudiness Delobbe
+ ! fracSC = .true. => Delobbe SCu Fractional Cloudiness Scheme
+ ! fracSC = .true. => may be setup if fracld = .true.
+ logical, parameter :: fracSC = .false.
+ ! fraCEP: SCu Fractional Cloudiness ECMWF
+ logical, parameter :: fraCEP = .false.
+
+ real, parameter :: thir5 = 1.66e0 ! cCA 5. / 3.
+
+ real, parameter :: eps1 = 1.e-01
+
+ ! cnor: intercept parameter / rain distribution ! Tuning
+ ! #if(LA)
+ ! real, parameter :: cnor = 3.0e06
+ ! #else
+ real, parameter :: cnor = 8.0e06
+ ! #endif
+
+ ! cnos: intercept parameter / snow distribution
+ real :: cnos
+
+ ! cnog: intercept parameter / graupel distribution
+ ! cnog: Lin et al. 1983, JCAM 22, p.1068 (1,2 and 3)
+ real, parameter :: cnog = 4.0e04
+
+ ! cnos2: intercept parameter / snow distribution
+ real, parameter :: cnos2 = 5.e06
+
+ real, parameter :: ui50 = 0.1e0
+ real, parameter :: ri50 = 5.e-5
+ real, parameter :: beta = 0.5e0
+
+ ! C1_EkM: Partial Condensation Scheme
+ real, parameter :: C1_EkM = 0.14e-3
+ ! C2_EkM: Ek and Mahrt 1991, An.Geoph. 9, 716--724
+ real, parameter :: C2_EkM = 9.75e+0
+
+ ! tsfo: minimum temperature (deg.C) before instant. cloud dropplets freezing
+ ! tsfo: Levkov et al.1992, C.Atm.Ph.65, p.39
+ real, parameter :: tsfo = -35.e0
+
+ ! WatIce, ExpWat, ExpWa2: Saturation pressure over Water, Dudhia (1989) JAS
+ real, parameter :: WatIce = 273.16e0
+ real, parameter :: ExpWat = 5.138e0
+ real, parameter :: ExpWa2 = 6827.e0
+
+ ! aM_Nid, bM_Nid, TM_Nid: Deposition Condensation-Freezing Nucleation Param.
+ ! aM_Nid, bM_Nid, TM_Nid: Meyers et al. (1992), p.713
+ ! real, parameter :: aM_Nid = -0.639
+ ! real, parameter :: bM_Nid = 0.1296
+ !XF
+ real, parameter :: aM_Nid = -1.488
+ ! bM_Nid: Prenni et al. (2007), p.545, BAMS
+ real, parameter :: bM_Nid = 0.0187
+ real, parameter :: TM_Nid = -5.
+
+ ! aM_Nic, bM_Nic, TM_Nic: Contact Freezing Nucleation Parameters
+ ! aM_Nic, bM_Nic, TM_Nic: Meyers et al. (1992), p.713
+ real, parameter :: aM_Nic = -2.80
+ real, parameter :: bM_Nic = 0.262
+ real, parameter :: TM_Nic = -2.
+
+#if(HM)
+ ! TmnNhm, TmxNhm, w_svrl: Hallet-Mossop Theory
+ ! see Levkov et al., (1992), Contr.Atm.Phy. 65, p.40
+ real, parameter :: TmnNhm = -8.
+ real, parameter :: TmxNhm = -3.
+ real, parameter :: w_svrl = 1.
+#endif
+
+ ! qsd0: Smallest Diameter of Particles in the snow Class
+ ! qsd0: Levkov et al. (1992), Contr. Atm. Phys. 65, p.41, para 1
+ real, parameter :: qsd0 = 2.0e-4
+
+ ! qi00: max. ice crystals concentr. before autoconv. of snow flakes occurs
+ ! qi00: Lin et al. (1983), JCAM 22, p.1070 (21)
+ real, parameter :: qi00 = 0.001e0
+ ! qi00 = 0.0008: compromise when graupels are not included
+ ! qi00 = 0.0008: Emde and Kahlig (1989), Ann.Geoph. 7, p.408 (18)
+ ! _hl data qi00/0.0008/
+
+ ! qg00: max. ice crystals concentr. before autoconversion of graupels occurs
+ ! qg00: Lin et al. (1983), JCAM 22, p.1074 (37)
+ real, parameter :: qg00 = 0.0006e0
+
+ ! sigmaw = 1/3 ln(1/k), where k=0.8 (dispersion parameter)
+ ! sigmaw: Martin et al. (1994), JAS 51, p.1823
+ real, parameter :: sigmaw = 0.27e+0
+
+#if(LO)
+ ! rcrilo: Autoconversion Critical Radius (Liou and Ou, 1989)
+ real, parameter :: rcrilo = 10.0e-6
+#endif
+
+#if(LI)
+ ! qw00L: maximum cloud droplets concentration before autoconversion occurs
+ ! qw00L: Lin et al. (1983), JCAM 22, p.1076 (50)
+ real, parameter :: qw00L = 0.002e0
+#endif
+
+ ! qi0S: critical solid water mixing ratio (tuned Dome C) (FacFIk > 1)
+ ! qi0S = 0.3e(-3) : critical solid water mixing ratio (standard)
+ real, parameter :: qi0S = 0.10e-3
+
+ ! qw00: critical liquid water mixing ratio
+ ! qw00 = 0.30e-3 -> standard value
+ ! qw00: Sundqvist (1988) : Physically-Based Modelling and
+ ! qw00: Simulation of Climate and Climatic Change,
+ ! qw00: M.E. Schlesinger, Ed., Reidel, 433-461.
+ real, parameter :: qw00 = 0.10e-3
+
+#if(SC)
+ real, parameter :: camart = 0.8e0
+ ! connw : droplets number concentration (m-3)
+ real, parameter :: connw = 1.2e8
+#endif
+
+ ! csud: charac. time scale for autoconversion (SUND), Sundqvist (1988)
+ real, parameter :: csud = 1.0e-4
+
+ ! typww: Typical Cloud Droplet Weight [Ton] (typ. diam.: 32.5 mim)
+ ! typww: (used with air Density rolv2D [Ton/m3])
+ real, parameter :: typww = 18.e-15
+
+ ! cc1, cc2, dd0: cloud droplets autoconversion parameters
+ real, parameter :: cc1 = 1.200e-04
+ real, parameter :: cc2 = 1.569e-12
+ real, parameter :: dd0 = 0.15e0
+
+ ! ==========================================================================
+ ! aa1, aa2: Bergeron Process Data (given by Koenig, 1971, J.A.S. 28,p235) ==
+
+ real, parameter, dimension(31) :: aa1 = (/ 0.7939e-07, 0.7841e-06, 0.3369e-05, 0.4336e-05, &
+ 0.5285e-05, 0.3728e-05, 0.1852e-05, 0.2991e-06, &
+ 0.4248e-06, 0.7434e-06, 0.1812e-05, 0.4394e-05, &
+ 0.9145e-05, 0.1725e-06, 0.3348e-04, 0.1725e-04, &
+ 0.9175e-05, 0.4412e-05, 0.2252e-05, 0.9115e-06, &
+ 0.4876e-06, 0.3473e-06, 0.4758e-06, 0.6306e-06, &
+ 0.8573e-06, 0.7868e-06, 0.7192e-06, 0.6513e-06, &
+ 0.5956e-06, 0.5333e-06, 0.4834e-06/)
+
+ real, parameter, dimension(31) :: aa2 = (/ 0.4006e0, 0.4831e0, 0.5320e0, 0.5307e0, 0.5319e0, &
+ 0.5249e0, 0.4888e0, 0.3894e0, 0.4047e0, 0.4318e0, &
+ 0.4771e0, 0.5183e0, 0.5463e0, 0.5651e0, 0.5813e0, &
+ 0.5655e0, 0.5478e0, 0.5203e0, 0.4906e0, 0.4447e0, &
+ 0.4126e0, 0.3960e0, 0.4149e0, 0.4320e0, 0.4506e0, &
+ 0.4483e0, 0.4460e0, 0.4433e0, 0.4413e0, 0.4382e0, &
+ 0.4361e0 /)
+
+ ! === Bergeron Process Data (given by Koenig, 1971, J.A.S. 28,p235) ========
+ ! ==========================================================================
+
+ ! Upper Limit for specific Humidity
+ ! =================================
+
+ ! SSImax: Maximum Sursaturation % ICE (900 ==> RH=1000%)
+#if(kk)
+ real, parameter :: SSImax = 900.
+#else
+ real, parameter :: SSImax = 101.0
+#endif
+
+ real, parameter :: relCri = 1.0
+ !#if(rc)
+ ! relCri = 0.9 + 0.08 * sqrt(max(0.,100. - dx*0.001) / 95.)
+ !#endif
+
+ ! ======== end declaration ============
+
+ ! Define constants
+ ! ================
+
+ ! Cloud Droplets Autoconversion Threshold
+ ! =======================================
+
+ ! cminHY: Cloud Fraction under which no Autoconversion occurs
+ cminHY = 1.0e-3
+
+ ! cnos: intercept parameter / snow distribution
+ cnos = 1.0e8
+#if(AC)
+ cnos = 3.0e8
+ ! old cnos over ANT
+ ! cnos = 5.e7
+ ! cnos = 3.e6
+#endif
+#if(GR)
+ cnos = 2.0e8
+#endif
+ ! #if(LA)
+ ! cnos = 4.0e6
+ ! #endif
+
+#if(LI)
+ qw00 = qw00L
+#endif
+
+#if(hb)
+ ! For Blown Snow Particles
+ ! ========================
+ ! do NOT USE unless for specific sensivity experiments
+ cnos = 0.1e18
+ if(itexpe == 0) write(6, 6000)
+ 6000 format(/, ' ****************************************************', &
+ /, ' * cnos = 0.1d18 for PURE BLOWING SNOW EXPERIMENTS *', &
+ /, ' * do not USE OTHERWISE *', &
+ /, ' ****************************************************', &
+ /)
+#endif
+
+ ! Update of Temperature
+ ! =====================
+
+ xt = min(dt, dtHyd)
+ xt = dtHyd2
+
+ qHeNu1 = 0
+ qHeNu2 = 0
+ qHeNu3 = 0
+
+ psacw = 0
+ psacr = 0
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ tair2D(il, kl) = pkta2D(il, kl) * pk2D(il, kl)
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'HYDmic: Debugged Variables: Initial'
+ debugH(36:70) = ' '
+ proc_1 = 'R.Hum W[%]'
+ procv1 = 0.1 * qv2D(il, kl) / (rhcrHY * qvsw2D(il, kl))
+ proc_2 = 'R.Hum I[%]'
+ procv2 = 0.1 * qv2D(il, kl) / (rhcrHY * qvsi2D(il, kl))
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ do kv = 1, 16
+ debugV(kv, kl) = 0.
+ enddo
+#endif
+ enddo
+ enddo
+
+ ! cCA variables initialization
+ do kl = 1, klev
+ do il = 1, klon
+ qrevp2D(il, kl) = 0.0
+ qssub2D(il, kl) = 0.0
+ enddo
+ enddo
+
+#if(EW)
+ ! Vertical Integrated Energy and Water Content
+ ! ============================================
+ do il = 1, klon
+ enr01D(il) = 0.0
+ wat01D(il) = 0.0
+ do kl = 1, klev
+ enr01D(il) = enr01D(il) &
+ + (tair2D(il, kl) &
+ - (qw2D(il, kl) + qr2D(il, kl)) * r_LvCp &
+ - (qi2D(il, kl) + qs2D(il, kl)) * r_LsCp) &
+ * dsigm1(kl)
+ wat01D(il) = wat01D(il) &
+ + (qv2D(il, kl) &
+ + qw2D(il, kl) + qr2D(il, kl) &
+ + qi2D(il, kl) + qs2D(il, kl)) &
+ * dsigm1(kl)
+ enddo
+ ! mphy2D --> '12345678901234567890'
+ mphy2D(il) = ' '
+#if(ew)
+ enr01D(il) = enr01D(il) * pst2Dn(il) * grvinv
+#endif
+ ! wat01D [m] contains an implicit factor (10.**3) [kPa-->Pa] /ro_Wat
+ wat01D(il) = wat01D(il) * pst2Dn(il) * grvinv
+ enddo
+#endif
+#if(WH)
+ vmmx = 0.0
+#endif
+
+ ! Set lower limit on Hydrometeor Concentration
+ ! ============================================
+
+ if(itPhys == 1) then
+ if(no_vec) then
+ do kl = mzhyd, klev
+ do il = 1, klon
+
+ if(qw2D(il, kl) < eps9) then
+ qv2D(il, kl) = qv2D(il, kl) + qw2D(il, kl)
+ tair2D(il, kl) = tair2D(il, kl) - qw2D(il, kl) * r_LvCp
+ dqw2D(il, kl) = dqw2D(il, kl) - qw2D(il, kl)
+ qw2D(il, kl) = 0.0
+ endif
+
+ if(qr2D(il, kl) < eps9) then
+ qv2D(il, kl) = qv2D(il, kl) + qr2D(il, kl)
+ tair2D(il, kl) = tair2D(il, kl) - qr2D(il, kl) * r_LvCp
+ dqw2D(il, kl) = dqw2D(il, kl) - qr2D(il, kl)
+ qr2D(il, kl) = 0.0
+ endif
+
+ if(qi2D(il, kl) < eps9 .or. ccni2D(il, kl) < unun) then
+ qv2D(il, kl) = qv2D(il, kl) + qi2D(il, kl)
+ tair2D(il, kl) = tair2D(il, kl) - qi2D(il, kl) * r_LsCp
+ dqi2D(il, kl) = dqi2D(il, kl) - qi2D(il, kl)
+ qi2D(il, kl) = 0.0
+ ccni2D(il, kl) = 0.0
+ endif
+
+ if(qs2D(il, kl) < eps9) then
+ qv2D(il, kl) = qv2D(il, kl) + qs2D(il, kl)
+ tair2D(il, kl) = tair2D(il, kl) - qs2D(il, kl) * r_LsCp
+ dqi2D(il, kl) = dqi2D(il, kl) - qs2D(il, kl)
+ qs2D(il, kl) = 0.0
+ endif
+ enddo
+ enddo
+ else
+ do kl = mzhyd, klev
+ do il = 1, klon
+ signQw = sign(unun, eps9 - qw2D(il, kl))
+ Qw0_OK = max(zero, signQw) * qw2D(il, kl)
+ qw2D(il, kl) = qw2D(il, kl) - Qw0_OK
+ dqw2D(il, kl) = dqw2D(il, kl) - Qw0_OK
+ qv2D(il, kl) = qv2D(il, kl) + Qw0_OK
+ tair2D(il, kl) = tair2D(il, kl) - Qw0_OK * r_LvCp
+
+ signQr = sign(unun, eps9 - qr2D(il, kl))
+ Qr0_OK = max(zero, signQr) * qr2D(il, kl)
+ qr2D(il, kl) = qr2D(il, kl) - Qr0_OK
+ dqw2D(il, kl) = dqw2D(il, kl) - Qr0_OK
+ qv2D(il, kl) = qv2D(il, kl) + Qr0_OK
+ tair2D(il, kl) = tair2D(il, kl) - Qr0_OK * r_LvCp
+
+ signQi = sign(unun, eps9 - qi2D(il, kl))
+ Qi0qOK = max(zero, signQi)
+ signCi = sign(unun, unun - ccni2D(il, kl))
+ Ci0cOK = max(zero, signCi)
+
+ Ci0_OK = max(Ci0cOK, Qi0qOK)
+ Qi0_OK = Ci0_OK * qi2D(il, kl)
+
+ ccni2D(il, kl) = ccni2D(il, kl) * Ci0_OK
+ qi2D(il, kl) = qi2D(il, kl) - Qi0_OK
+ dqi2D(il, kl) = dqi2D(il, kl) - Qi0_OK
+ qv2D(il, kl) = qv2D(il, kl) + Qi0_OK
+ tair2D(il, kl) = tair2D(il, kl) - Qi0_OK * r_LsCp
+
+ signQs = sign(unun, eps9 - qs2D(il, kl))
+ Qs0_OK = max(zero, signQs) * qs2D(il, kl)
+ qs2D(il, kl) = qs2D(il, kl) - Qs0_OK
+ dqi2D(il, kl) = dqi2D(il, kl) - Qs0_OK
+ qv2D(il, kl) = qv2D(il, kl) + Qs0_OK
+ tair2D(il, kl) = tair2D(il, kl) - Qs0_OK * r_LsCp
+ enddo
+ enddo
+ endif
+ endif
+
+ ! Update of dummy Variables
+ ! =========================
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ W2xyz1(il, kl) = tair2D(il, kl) - TfSnow
+ ! W2xyz2 : Ice Crystals Number (Fletcher, 1962)
+ W2xyz2(il, kl) = 1.e-2 * exp(-0.6 * W2xyz1(il, kl))
+
+ W2xyz3(il, kl) = qr2D(il, kl)
+ W2xyz4(il, kl) = qs2D(il, kl)
+#if(qg)
+ W2xyz0(il, kl) = qg2D(il, kl)
+#endif
+#if(WH)
+ ! old values
+ if(il == ilmm) then
+ qwold(kl) = qw2D(il, kl)
+ qiold(kl) = qi2D(il, kl)
+ endif
+#endif
+ enddo
+ enddo
+
+ ! Saturation Specific Humidity
+ ! ============================
+
+ ! ***********
+ call qsat2D(tair2D, pst2D, tsrf2D, qvsi2D, qvsw2D)
+ ! ***********
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ ! W2xyz5: Saturation Specific Humidity over Ice
+ W2xyz5(il, kl) = rhcrHY * qvsi2D(il, kl)
+
+ W2xyz6(il, kl) = sqrt((pst2Dn(il) + ptopDY) &
+ / (rolv2D(il, kl) * RDryAi * tair2D(il, klev)))
+#if(VW)
+ ! Cloud Droplets Fall Velocity
+ ! (Calcul de la Vitesse Terminale Moyenne)
+ ! ----------------------------
+ if(qw2D(il, kl) >= eps9) then
+ ! ccnw2D: ASTEX case (Duynkerke et al. 1995, JAS 52, p.2763)
+ ccnw2D(il, kl) = 1.2d8
+ qwclou = qw2D(il, kl) / max(cminHY, cfra2D(il, kl))
+ dmed0 = 4.5 * sigmaw * sigmaw
+ dmedv = 12.5 * sigmaw * sigmaw
+ dmede = qwclou * rolv2D(il, kl) &
+ * 6.d0 / (pi * ccnw2D(il, kl) * exp(dmed0))
+ dmed5 = exp(thir5 * log(dmede))
+ ! dmed = exp(third*log(dmede))
+ vw(il, kl) = 1.19d8 * pi * ccnw2D(il, kl) * dmed5 &
+ * exp(dmedv) / (24.0 * rolv2D(il, kl) * qwclou)
+ else
+ vw(il, kl) = 0.00
+ endif
+#endif
+
+ ! Rain Fall Velocity
+ ! ------------------
+
+ ! W2xyz7(il,kl) : lambda_r : Marshall-Palmer Distribution Parameter
+ ! for Rain
+ ! Note that a simplification occurs
+ ! between the 1000. factor of rho, and rho_water=1000.
+ ! Reference : Emde and Kahlig (1989), Ann.Geoph. 7, p.407 (3)
+ W2xyz7(il, kl) = exp(0.25 * log((pi * cnor) &
+ / (rolv2D(il, kl) * max(eps9, qr2D(il, kl)))))
+
+ if(qr2D(il, kl) > eps9) then
+ ! vr__OK = 1. if qr2D(il,kl) > eps9
+ ! vr__OK = 0. otherwise
+ signVR = sign(unun, qr2D(il, kl) - eps9)
+ vr__OK = max(zero, signVR)
+
+ ! vr : Terminal Fall Velocity for Rain
+ ! 392 = a Gamma[4+b] / 6 where a = 842. and b = 0.8
+ vr(il, kl) = vr__OK * 392. * W2xyz6(il, kl) &
+ / exp(0.8 * log(W2xyz7(il, kl)))
+ else
+ vr(il, kl) = 0.
+ endif
+
+ ! Snow Fall Velocity
+ ! ------------------
+
+ ! W2xyz8(il,kl) : lambda_s : Marshall-Palmer distribution parameter
+ ! for Snow Flakes
+ ! Note that a partial simplification occurs
+ ! between the 1000. factor of rho, and rho_snow=500.
+ ! Reference : Emde and Kahlig 1989, Ann.Geoph. 7, p.407 (3)
+ ! (rho_snow) Levkov et al. 1992, Cont.Atm.Phys. 65(1) p.37 (5)
+#if(cn)
+ cnos = min(2.e8, cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ W2xyz8(il, kl) = exp(0.25 * log((0.50 * pi * cnos) &
+ / (rolv2D(il, kl) * max(eps9, qs2D(il, kl)))))
+
+ if(qs2D(il, kl) > eps9) then
+ ! vs__OK = 1. if qs2D(il,kl) > eps9
+ ! vs__OK = 0. otherwise
+ signVS = sign(unun, qs2D(il, kl) - eps9)
+ vs__OK = max(zero, signVS)
+
+ ! vs: Terminal Fall Velocity for Snow Flakes
+ ! 2.19 = c Gamma[4+d] / 6
+ ! where c = 4.836 = 0.86 *1000.**0.25
+ ! and d = 0.25
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Graupellike Snow Flakes of Hexagonal Type)
+ vs(il, kl) = vs__OK * 2.19 * W2xyz6(il, kl) &
+ / exp(0.25 * log(W2xyz8(il, kl)))
+ ! old option #up
+ ! OR 2976. = c Gamma[4+d] / 6
+ ! where c = 755.9 = 0.81 *1000.**0.99 and d = 0.99
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Unrimed Side Planes)
+ vs(il, kl) = vs__OK * 2976. * W2xyz6(il, kl) &
+ / exp(0.99 * log(W2xyz8(il, kl)))
+#if(ur)
+ ! OR 2976. = c Gamma[4+d] / 6
+ ! where c = 755.9 = 0.69 *1000.**0.41 and d = 0.41
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Aggregates of unrimed radiating assemblages)
+ vs(il, kl) = vs__OK * 20.06 * W2xyz6(il, kl) &
+ / exp(0.41 * log(W2xyz8(il, kl)))
+#endif
+ else
+ vs(il, kl) = 0.0
+ endif
+
+#if(qg)
+ ! Graupel Fall Velocity
+ ! ---------------------
+ if(qg2D(il, kl) >= eps9) then
+ ! Don't forget "#hy" option !
+ ! W2xyz9(il,kl) : lambda_g : Marshall-Palmer distrib. parameter
+ ! for Graupel
+ ! Note that a simplification occurs
+ ! between the 1000. factor of rho, and rho_ice=1000.
+ W2xyz9(il, kl) = exp(0.250 * log((pi * cnog) &
+ / (rolv2D(il, kl) * max(eps9, qg2D(il, kl)))))
+ ! vh: Terminal Fall Velocity for Graupels
+ ! 25.1 = c Gamma[4+d] / 6
+ ! where c = 4.836 = 1.10 *1000.**0.57 and d = 0.57
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Hexagonal Graupel)
+ vh(il, kl) = 25.1 * W2xyz6(il, kl) &
+ / exp(0.57 * log(W2xyz9(il, kl)))
+ else
+ vh(il, kl) = 0.0
+ W2xyz9(il, kl) = 0.0
+ endif
+#endif
+ enddo
+ enddo
+
+ ! ===================================================================
+ ! Microphysical Processes affecting non Precipitating Cloud Particles
+ ! ===================================================================
+ ! Homogeneous Nucleation by Cloud Dropplets Solidification ! BFREWI
+ ! Ref: Emde and Kahlig 1989, Ann.Geoph. 7, p.407 (11) ! Levkov (24) p.40
+ ! ---------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qHoNuc = 0.
+ qHeNuc = 0.
+ qwOK = 0.
+#endif
+ if(W2xyz1(il, kl) < tsfo) then
+ ! qHoNuc = 1. if W2xyz1(il,kl) < tsfo
+ ! qHoNuc = 0. otherwise
+ signHN = -sign(unun, W2xyz1(il, kl) - tsfo)
+ qHoNuc = max(zero, signHN)
+#if(EW)
+ if(qHoNuc > epsi) then ! ctr
+ mauxEW = mphy2D(il)
+ mauxEW(01:01) = 'i'
+ mphy2D(il) = mauxEW
+ ENDif ! ctr
+#endif
+ qwOK = qw2D(il, kl) * qHoNuc
+ qi2D(il, kl) = qi2D(il, kl) + qwOK
+ ccni2D(il, kl) = ccni2D(il, kl) + rolv2D(il, kl) * qwOK / typww
+ tair2D(il, kl) = tair2D(il, kl) + r_LcCp * qwOK
+#if(WQ)
+ write(6, *) 'Qihm1', qw2D(il, kl), &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+ if(il == ilmm) wihm1(kl) = qwOK
+#endif
+ qw2D(il, kl) = qw2D(il, kl) - qwOK
+
+ endif
+
+ ! Heterogeneous Freezing of Cloud Droplets ! BNUFWI
+ ! Reference: Levkov et al., 1992 (21) p.40 ! Levkov (21) p.40
+ ! ----------------------------------------
+
+ !!#qf #hy if(W2xyz1(il,kl) < 0.00) then
+
+ !!#qf signHN = -sign(unun,W2xyz1(il,kl) - 0.)
+ ! qHeNuc = 1.0 if W2xyz1(il,kl) < 0.00dgC
+ ! = 0.0 otherwise
+ !!#qf qHeNuc = max(zero,signHN)
+
+ !!#qf argexp = min(max(argmin,-W2xyz1(il,kl)),argmax)
+ !!#qf qHeNuc = qHeNuc*(exp(argexp) - 1. ) &
+ !!#qf * qw2D(il,kl) * 100.0 *typww
+ !!#qf qHeNuc = min(qHeNuc, qw2D(il,kl))
+
+ !!#qf qi2D(il,kl) = qi2D(il,kl) + qHeNuc
+ !!#qf ccni2D(il,kl) = ccni2D(il,kl) + rolv2D(il,kl)*qHeNuc/typww
+ !!#qf tair2D(il,kl) = tair2D(il,kl) + r_LcCp *qHeNuc
+ !!#qf qw2D(il,kl) = qw2D(il,kl) - qHeNuc
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Homo+Hetero Nucleation by Droplets '
+ debugH(36:70) = 'Solidification (BFREWI+BNUFWI) '
+ proc_1 = 'BFREWI '
+ procv1 = qHoNuc
+ proc_2 = 'BNUFWI '
+ procv2 = qHeNuc
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(01, kl) = qwOK + qHeNuc
+#endif
+ !!#qf #hy end if
+
+#if(EW)
+ !===================================================================
+ ! Homogeneous Sublimation ! XXXXXX
+ ! Ref: Emde and Kahlig 1989, Ann.Geoph. 7, p.407 (12) ! Levkov
+ ! ---------------------------------------------------------
+ if(qHoNuc > epsi) then ! ctr
+ mauxEW = mphy2D(il)
+ mauxEW(02:02) = 'I'
+ mphy2D(il) = mauxEW
+ ENDif ! ctr
+#endif
+#if(hs)
+ ! 1.733e7=Ls*Ls*0.622/Cpa/Ra with Ls = 2833600 J/kg
+ dpv = (qv2D(il, kl) - W2xyz5(il, kl)) &
+ / (1.d0 + 1.733e7 * W2xyz5(il, kl) &
+ / (tair2D(il, kl) * tair2D(il, kl)))
+ dpv = qHoNuc * max(zero, dpv)
+ dqv = dpv
+ qi2D(il, kl) = qi2D(il, kl) + dqv
+ dqi2D(il, kl) = dqi2D(il, kl) + dqv
+ ! ccni2D(il,kl) : NO VARIATION
+ qv2D(il, kl) = qv2D(il, kl) - dqv
+ tair2D(il, kl) = tair2D(il, kl) + r_LsCp * dqv
+#endif
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'Qihm2', dqv, &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wihm2(kl) = dqv
+#endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Emde and Kahlig: Homogeneous Sublim'
+ debugH(36:70) = 'ation '
+ proc_1 = 'dQv g/kg'
+ procv1 = dqv
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = 'CCNI/1.e15'
+ procv4 = ccni2D(il, kl) * 1.e-18
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(01, kl) = dqv + debugV(01, kl)
+#endif
+ enddo
+ enddo
+
+ !===========================================================================
+ ! Nucleation I: Deposition & Condensation-Freezing Nucleat.
+ ! Source : Water Vapor ! BNUCVI
+ ! Reference: Meyers et al., 1992, JAM 31, (2.4) p.712 ! Levkov (20) p.40
+ ! -----------------------------------------------------------
+ if(Meyers) then
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qHeNuc = 0.
+ qicnd1 = 0.
+ dqi1 = 0.
+ dqi2 = 0.
+ dqi3 = 0.
+#endif
+ if(W2xyz1(il, kl) < TM_Nid) then
+ ! qHeNu1 = 1.0 if W2xyz1(il,kl) < TM_Nid
+ ! qHeNu1 = 0.0 otherwise
+ signHN = -sign(unun, W2xyz1(il, kl) - TM_Nid)
+ qHeNu1 = max(zero, signHN)
+
+ ! Sursaturation
+ dqv = qv2D(il, kl) - W2xyz5(il, kl)
+ dqv = max(zero, dqv)
+
+ if(dqv > 0.) then
+ ! qHeNu3 = 1.0 if qv2D(il,kl) > W2xyz5(il,kl)
+ ! qHeNu3 = 0.0 otherwise
+ signHN = sign(unun, dqv)
+ qHeNu3 = max(zero, signHN)
+
+ qHeNuc = qHeNu1 * qHeNu3
+
+ ! Sursaturation relative to ice
+ ! Meyers et al. (1992) JAM, 2.4
+ qicnd1 = 1.0e2 * dqv / W2xyz5(il, kl)
+ qicnd1 = min(qicnd1, SSImax)
+ qicnd1 = 1.0e3 * exp(aM_Nid + bM_Nid * qicnd1)
+ qicnd1 = max(qicnd1 - ccni2D(il, kl), zero) * qHeNuc
+ ccni2D(il, kl) = ccni2D(il, kl) + qicnd1
+ ! 1.e-15 = 0.001 * Initial Ice Crystal Mass
+ dqi = 1.0e-15 * qicnd1 / rolv2D(il, kl)
+ dqi = min(dqi, dqv)
+ qi2D(il, kl) = qi2D(il, kl) + dqi
+ dqi2D(il, kl) = dqi2D(il, kl) + dqi
+ qv2D(il, kl) = qv2D(il, kl) - dqi
+ tair2D(il, kl) = tair2D(il, kl) + dqi * r_LsCp
+ dqi1 = dqi
+
+ endif
+ endif
+
+ ! Nucleation I: Contact -Freezing Nucleat.
+ ! Source : Cloud Dropplets ! BSPRWI
+ ! Ref: Meyers et al. (1992), JAM 31, 2.6 p.713 ! Levkov (20) p.40
+ ! -----------------------------------------------------------
+#if(wH)
+ qicnd1 = 0.
+ qicnd2 = 0.
+ dqi = 0.
+#endif
+ if(qw2D(il, kl) > 0.) then
+ ! qHeNu3 = 1.0 if qw2D(il,kl) > 0.
+ ! qHeNu3 = 0.0 otherwise
+ signHN = sign(unun, qw2D(il, kl))
+ qHeNu3 = max(zero, signHN)
+
+ if(W2xyz1(il, kl) < TM_Nic) then
+ ! qHeNu2 = 1.0 if W2xyz1(il,kl) < TM_Nic
+ ! qHeNu2 = 0.0 otherwise
+ signHN = -sign(unun, W2xyz1(il, kl) - TM_Nic)
+ qHeNu2 = max(zero, signHN)
+
+ qHeNuc = qHeNu1 * qHeNu3
+
+ ! Contact-Freez Potent.Nuclei
+ ! Meyers et al. (1992) JAM, 2.6
+ qicnd1 = 1.e3 * qHeNuc &
+ * exp(aM_Nic - bM_Nic * W2xyz1(il, kl))
+ rad_ww = (1.e3 * rolv2D(il, kl) &
+ * qw2D(il, kl) * .2e-11)**0.33
+ ! .2 e-11 = 1. / (1.2e+8 * 1.e3 * 4.19)
+ ! ccnw2D (ASTEX) ro_w 4 pi /3
+ ! Levkov et al. 1992 CAM, (23)
+ qicnd2 = 603.2e+3 * qicnd1 * rad_ww &
+ * rolv2D(il, kl)
+ ! 603.2e3 = 4.0e-7 * 4 pi * 1.2e+8 * 1.e3
+ ! DFar ccnw2D fact(rolv)
+ ccni2D(il, kl) = ccni2D(il, kl) + qicnd2
+ dqi = 1.e-15 * qicnd2 / rolv2D(il, kl)
+ ! 1.e-15 = 1.0e-3 * Ice Crystal Mass
+ dqi = min(qw2D(il, kl), dqi)
+ ! XF 09/07/2019,too much qi vs qw
+ if(dqi > 0) dqi = dqi / 2.
+ qi2D(il, kl) = qi2D(il, kl) + dqi
+ qw2D(il, kl) = qw2D(il, kl) - dqi
+ tair2D(il, kl) = tair2D(il, kl) + dqi * r_LcCp
+ dqi2 = dqi
+ endif
+ endif
+#if(HM)
+ ! Nucleation II: Hallett-Mossop Ice-Multiplication Proc. ! BSPRWI
+ ! Reference: Levkov et al., 1992, Contr.Atm.Ph.65,(25) p.40 ! Levkov (25) p.40
+ ! -----------------------------------------------------------
+ if(W2xyz1(il, kl) < TmxNhm .and. &
+ W2xyz1(il, kl) > TmnNhm .and. &
+ wair2D(il, kl) > w_svrl) then
+ ! qHeNu1 = 1.0 if W2xyz1(il,kl) < TmxNhm
+ ! qHeNu1 = 0.0 otherwise
+ signHN = -sign(unun, W2xyz1(il, kl) - TmxNhm)
+ qHeNu1 = max(zero, signHN)
+ ! qHeNu2 = 1.0 if W2xyz1(il,kl) > TmnNhm
+ ! qHeNu2 = 0.0 otherwise
+ signHN = sign(unun, W2xyz1(il, kl) - TmnNhm)
+ qHeNu2 = max(zero, signHN)
+ ! qHeNu3 = 1.0 if wair2D(il,kl) > w_svrl
+ ! qHeNu3 = 0.0 otherwise
+ signHN = sign(unun, wair2D(il, kl) - w_svrl)
+ qHeNu3 = max(zero, signHN)
+#if(cn)
+ cnos = min(2.e8, &
+ cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ SplinJ = 1.358e12 * qw2D(il, kl) * cnos / &
+ (W2xyz8(il, kl)**.33)
+ ! 1.358e12=pi *Gamma(3.5) *g *ro_s /(3 *Cd *4.19e-12)
+ ! [=3.14 *3.3233625 *9.81*0.1 /(3 *0.6 *4.19e-12)]
+ SplinP = 0.003 * (1. - 0.05 * SplinJ) * qHeNu1 * qHeNu2 &
+ * qHeNu3
+ SplinP = max(zero, SplinP)
+ dqi = 1.e-15 * SplinP / &
+ rolv2D(il, kl)
+ ! 1.e-15 = 1.0e-3 * Ice Crystal Mass
+ SplinP = (min(1.0, qs2D(il, kl) / max(dqi, eps9))) * SplinP
+ ccni2D(il, kl) = ccni2D(il, kl) + SplinP
+ dqi = min(qs2D(il, kl), dqi)
+ qi2D(il, kl) = qi2D(il, kl) + dqi
+ dqi2D(il, kl) = dqi2D(il, kl) + dqi
+ qs2D(il, kl) = qs2D(il, kl) - dqi
+ dqi3 = dqi
+ endif
+#endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Meyers: Nucl. I, Depot & Cond-Freez'
+ debugH(36:70) = 'Nucl. / Freez / Nucl. II / Bergeron'
+ proc_1 = 'dQi1 Meyer'
+ procv1 = dqi1
+ proc_2 = 'dQi2 Meyer'
+ procv2 = dqi2
+ proc_3 = 'dQi Ha-Mos'
+ procv3 = dqi3
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(02, kl) = dqi1 + dqi2 + dqi3
+#endif
+ enddo
+ enddo
+ !=======================================================================
+ else
+
+ !=======================================================================
+ ! Ice Crystals Nucleation Process between 0.C and -35.C
+ ! (each crystal has a mass equal or less than 10d-12 kg)
+ ! Reference: Emde and Kahlig 1989, Ann.Geoph. 7, p.408 (13)
+ ! ---------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qicnd1 = 0.
+ qicnd2 = 0.
+ qicnd = 0.
+#endif
+ if(W2xyz1(il, kl) > tsfo) then
+
+ ! qHeNu1 = 1.0 if W2xyz1(il,kl) > tsfo
+ ! qHeNu1 = 0.0 otherwise
+ signHN = sign(unun, W2xyz1(il, kl) - tsfo)
+ qHeNu1 = max(zero, signHN)
+
+ if(W2xyz1(il, kl) < 0.) then
+
+ ! qHeNu2 = 1.0 if W2xyz1(il,kl) < 0.
+ ! qHeNu2 = 0.0 otherwise
+ signHN = -sign(unun, W2xyz1(il, kl))
+ qHeNu2 = max(zero, signHN)
+
+ if(qv2D(il, kl) > W2xyz5(il, kl)) then
+
+ ! qHeNu3 = 1.0 if qv2D(il,kl) > W2xyz5(il,kl)
+ ! qHeNu3 = 0.0 otherwise
+ signHN = sign(unun, qv2D(il, kl) - W2xyz5(il, kl))
+ qHeNu3 = max(zero, signHN)
+
+ qHeNuc = qHeNu1 * qHeNu2 * qHeNu3
+#if(EW)
+ if(qHeNuc > epsi) then ! ctr
+ mauxEW = mphy2D(il)
+ mauxEW(03:03) = 'I'
+ mphy2D(il) = mauxEW
+ ENDif ! ctr
+#endif
+ ! qicnd1 : amount of nucleated ice crystals
+ ! (first condition)
+ qicnd1 = qHeNuc * 1.e-15 * W2xyz2(il, kl) / &
+ rolv2D(il, kl)
+
+ qisign = sign(unun, qicnd1 - qi2D(il, kl))
+ qi1_OK = max(zero, qisign)
+ qicnd1 = qicnd1 * qi1_OK
+
+ ! qicnd2 : amount of nucleated ice crystals
+ ! (second condition)
+ qicnd2 = (qv2D(il, kl) - W2xyz5(il, kl)) / &
+ (1.d0 + 1.733d7 * W2xyz5(il, kl) / &
+ (tair2D(il, kl) * tair2D(il, kl)))
+ qicnd2 = qHeNuc * max(zero, qicnd2)
+
+ qicnd = min(qicnd1, qicnd2)
+
+ qi2D(il, kl) = qi2D(il, kl) + qicnd
+ dqi2D(il, kl) = dqi2D(il, kl) + qicnd
+ ccni2D(il, kl) = ccni2D(il, kl) + rolv2D(il, kl) * &
+ qicnd * 1.e15
+ qv2D(il, kl) = qv2D(il, kl) - qicnd
+ tair2D(il, kl) = tair2D(il, kl) + r_LsCp * qicnd
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'QiCnd', qicnd, &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wicnd(kl) = qicnd
+#endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Emde and Kahlig: Ice Crystals Nucle'
+ debugH(36:70) = 'ation Process between 0.C and -35.C'
+ proc_1 = 'Qicnd1 '
+ procv1 = qicnd1
+ proc_2 = 'Qicnd2 '
+ procv2 = qicnd2
+ proc_3 = 'Qicnd g/kg'
+ procv3 = qicnd
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(02, kl) = qicnd
+#endif
+ endif
+ endif
+ endif
+ enddo
+ enddo
+ endif
+
+ !===========================================================================
+ ! Bergeron Process (water vapor diffusion-deposition on ice crystals)
+ ! Reference: Koenig 1971, J.A.S. 28, p.235
+ ! Emde and Kahlig 1989, Ann.Geoph. 7, p.408 (14)
+ ! ---------------------------------------------------------
+
+ if(.not. LevkovAUTX) then
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qBerge = 0.
+ qidep = 0.
+ qicnd = 0.
+#endif
+ if(qi2D(il, kl) > eps9 .and. W2xyz1(il, kl) < 0.) then
+
+ ! qBerge = 1.0 if qi2D(il,kl) > eps9
+ ! qBerge = 0.0 otherwise
+ signHN = sign(unun, qi2D(il, kl) - eps9)
+ qBerge = max(zero, signHN)
+
+ ! qHeNuc = 1.0 if W2xyz1(il,kl) < 0.
+ ! qHeNuc = 0.0 otherwise
+ signHN = -sign(unun, W2xyz1(il, kl))
+ qHeNuc = max(zero, signHN)
+
+ qBerge = qHeNuc * qBerge
+#if(EW)
+ if(qBerge > epsi) then ! ctr
+ mauxEW = mphy2D(il)
+ mauxEW(04:04) = 'i'
+ mphy2D(il) = mauxEW
+ ENDif ! ctr
+#endif
+ itc = abs(W2xyz1(il, kl) - unun)
+ itc = min(itc, 31)
+ itc = max(itc, 1)
+ a1 = aa1(itc)
+ a2 = aa2(itc)
+
+ ! amf : analytical integration of
+ ! (14) p.408 Emde and Kahlig 1989, Ann.Geoph. 7
+ am0 = 1.d+3 * rolv2D(il, kl) * qi2D(il, kl) / W2xyz2(il, kl)
+ amf = (a1 * (1.0 - a2) * xt + am0**(1.0 - a2))**(1.0 / (1.0 - a2))
+ qidep = (1.d-3 * W2xyz2(il, kl) / rolv2D(il, kl)) * (amf - am0)
+ qidep = max(zero, qidep)
+
+ ! qicnd : to avoid the use of qw2D < 0.
+ qicnd = max(zero, qw2D(il, kl))
+
+ qidep = qBerge * min(qicnd, qidep)
+
+ ! XF 09/07/2019,too much qi vs qw
+ if(qidep > 0) qidep = qidep / 2.
+
+ ! ccni2D(il,kl): NO VARIATION
+ qi2D(il, kl) = qi2D(il, kl) + qidep
+
+ qw2D(il, kl) = qw2D(il, kl) - qidep
+ tair2D(il, kl) = tair2D(il, kl) + r_LcCp * qidep
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'QiDep', qidep, &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) widep(kl) = qidep
+#endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Bergeron Process (water vapor diffu'
+ debugH(36:70) = 'sion-deposition on ice crystals) '
+ proc_1 = 'qBerge ICE'
+ procv1 = qBerge
+ proc_2 = 'Qicnd g/kg'
+ procv2 = qicnd
+ proc_3 = 'Qidep g/kg'
+ procv3 = qidep
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(02, kl) = qidep + debugV(02, kl)
+#endif
+ endif
+ enddo
+ enddo
+ endif
+
+ !===========================================================================
+
+ ! Ice Crystals Sublimation ! BDEPVI
+ ! Reference: Emde and Kahlig, 1989 p.408 (15) ! Levkov (27) p.40
+ ! -------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qisub = 0.
+#endif
+ if(W2xyz5(il, kl) > qv2D(il, kl)) then
+ qvdfci = W2xyz5(il, kl) - qv2D(il, kl)
+ ! qSubl1 = 1.0 if W2xyz5(il,kl) > qv2D(il,kl)
+ ! = 0.0 otherwise
+ !!#pp signHN = sign(unun,qvdfci)
+ !!#pp qSubl1 = max(zero,signHN)
+ if(qi2D(il, kl) > eps9) then
+ ! qSubl2 = 1.0 if qi2D(il,kl) > eps9
+ ! qSubl2 = 0.0 otherwise
+ signHN = sign(unun, qi2D(il, kl) - eps9)
+ qSubl2 = max(zero, signHN)
+
+ qSubli = qSubl2
+ !!#pp qSubli = qSubli * qSubl1
+#if(EW)
+ if(qSubli > epsi) then ! ctr
+ mauxEW = mphy2D(il)
+ mauxEW(05:05) = 'V'
+ mphy2D(il) = mauxEW
+ ENDif ! ctr
+#endif
+ demde = 1.1d+4
+ sat = qv2D(il, kl) / W2xyz5(il, kl)
+ ab1 = 6.959d+11 / (tair2D(il, kl) * tair2D(il, kl))
+ ! 6.959e+11
+ != [Ls=2833600J/kg] * Ls / [kT=0.025W/m/K] / [Rv=461.J/kg/K]
+ ! kT: Air thermal Conductivity
+ ab2 = 1.d0 / (1.875d-2 * rolv2D(il, kl) * W2xyz5(il, kl))
+ ! 1.875d-5: Water Vapor Diffusivity in Air !cCA WARNING
+ pisub = (1 - sat) * 4.d0 * demde * W2xyz2(il, kl) / (ab1 + ab2)
+ qisub = pisub * xt
+ ! H2O deposition limit = H2O content
+ qisub = max(qisub, -qv2D(il, kl))
+ ! qi sublimation limit = qi content
+ qisub = min(qisub, qi2D(il, kl))
+ ! qi sublimation limit = Saturation
+ qisub = min(qisub, qvdfci) * qSubli
+
+ qi2D(il, kl) = qi2D(il, kl) - qisub
+ dqi2D(il, kl) = dqi2D(il, kl) - qisub
+ qv2D(il, kl) = qv2D(il, kl) + qisub
+ tair2D(il, kl) = tair2D(il, kl) - r_LsCp * qisub
+
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'QiSub', qisub, &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wisub(kl) = qisub
+#endif
+
+ endif
+ endif
+#if(wH)
+ ! +--Debug
+ ! + ~~~~~
+ debugH(1:35) = 'Emde and Kahlig: Ice Crystals Subli'
+ debugH(36:70) = 'mation '
+ proc_1 = 'Qisub g/kg'
+ procv1 = qisub
+ proc_2 = 'R.Hum I[%]'
+ procv2 = 0.1 * sat
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(03, kl) = -qisub
+#endif
+ enddo
+ enddo
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ if(qi2D(il, kl) <= 0.) then
+ qi2D(il, kl) = 0.
+ ccni2D(il, kl) = 0.
+ endif
+ enddo
+ enddo
+
+ !===========================================================================
+
+ ! Ice Crystals Instantaneous Melting
+ ! ----------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qimlt = 0.
+ cimlt = 0.
+#endif
+ if(W2xyz1(il, kl) > 0.) then
+
+ ! qMelt1 = 1.0 if W2xyz1(il,kl) > 0.
+ ! qMelt1 = 0.0 otherwise
+ signHN = sign(unun, W2xyz1(il, kl))
+ qMelt1 = max(zero, signHN)
+
+ if(qi2D(il, kl) > eps9) then
+
+ ! qMelt2 = 1.0 if qi2D(il,kl) > eps9
+ ! qMelt2 = 0.0 otherwise
+ signHN = sign(unun, qi2D(il, kl) - eps9)
+ qMelt2 = max(zero, signHN)
+
+ qMelt = qMelt1 * qMelt2
+#if(EW)
+ ! ctr
+ if(qMelt > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(06:06) = 'w'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ qxmlt = W2xyz1(il, kl) / r_LcCp
+ qimlt = min(qi2D(il, kl), qxmlt) * qMelt
+ cimlt = ccni2D(il, kl) * qimlt / max(qi2D(il, kl), eps9)
+ qi2D(il, kl) = qi2D(il, kl) - qimlt
+ ccni2D(il, kl) = ccni2D(il, kl) - cimlt
+ qw2D(il, kl) = qw2D(il, kl) + qimlt
+ tair2D(il, kl) = tair2D(il, kl) - r_LcCp * qimlt
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'QiMlt', qimlt, &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wimlt(kl) = qimlt
+#endif
+
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Emde and Kahlig: Ice Crystals Insta'
+ debugH(36:70) = 'ntaneous Melting '
+ proc_1 = 'Qimlt g/kg'
+ procv1 = qimlt
+ proc_2 = 'cimlt /e15'
+ procv2 = cimlt * 1.e-18
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(04, kl) = -qimlt
+#endif
+ enddo
+ enddo
+
+ !================================================================
+ ! Water Vapor Condensation / Evaporation (Fractional Cloudiness)
+ ! Reference: Laurent Delobbe Thesis (Ek&Mahrt91)
+ ! --------------------------------------------------------------
+
+ ! Zeroing needed since cfra2D build from a maximization process
+ do kl = mzhyd, klev
+ do il = 1, klon
+ ! cfra2D: Cloud Fraction
+ cfra2D(il, kl) = 0.0
+ enddo
+ enddo
+
+ if(fracld .and. fracSC) then
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ dqw = 0.
+#endif
+ if(W2xyz1(il, kl) >= tsfo) then
+#if(EW)
+ if(W2xyz1(il, kl) >= tsfo) then ! ctr
+ mauxEW = mphy2D(il)
+ mauxEW(07:07) = 'W'
+ mphy2D(il) = mauxEW
+ ENDif ! ctr
+#endif
+ ! qHeNu1 = 1.0 if W2xyz1(il,kl) > tsfo
+ ! qHeNu1 = 0.0 otherwise
+ signHN = sign(unun, W2xyz1(il, kl) - tsfo)
+ qHeNu1 = max(zero, signHN)
+
+ ! qt : Total Water Mixing Ratio
+ qt = qv2D(il, kl) + qw2D(il, kl)
+
+ ! tl : Liquid Temperature
+ tl = tair2D(il, kl) - r_LvCp * qw2D(il, kl)
+
+ ! Saturation specific humidity over water,
+ ! corresponding to liquid temperature
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! Dudhia (1989) JAS, (B1) and (B2) p.3103
+ ! See also Pielke (1984), p.234 and Stull (1988), p.276
+ pa_hPa = (pst2Dn(il) * sigma(kl) + ptopDY) * 10.d0
+ es_hPa = 6.1078d0 * exp(ExpWat * log(WatIce / tl)) &
+ * exp(ExpWa2 * (unun / WatIce - unun / tl))
+
+ ! Saturation Vapor Specific Concentration over Water
+ ! (even for temperatures less than freezing point)
+ qsl = .622d0 * es_hPa / (pa_hPa - .378d0 * es_hPa)
+
+ ! Partial Condensation/Scheme
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dqt = qv2D(il, MIN(kl + 1, klev)) - qv2D(il, kl) &
+ + qw2D(il, MIN(kl + 1, klev)) - qw2D(il, kl)
+ wqt = TUkv2D(il, kl) * dqt &
+ / (gplv2D(il, kl + 1) - gplv2D(il, kl)) * gravit
+
+ ! ww : Vertical Velocity Variance
+ ww = 0.66d0 * ect_2D(il, kl)
+
+ ! sig2rh : Relative Humidity Variance
+ ! (Ek and Mahrt, 1991, An. Geoph., 9, 716--724)
+ coefC2 = wqt / (sqrt(ww) * qsl)
+ sig2rh = C1_EkM + C2_EkM * coefC2 * coefC2
+
+ ! sigqt : Total Water Variance
+ sigqt = sqrt(sig2rh) * qsl
+
+ argerf = (qt - qsl) / (1.414d0 * sigqt)
+ err = erf(argerf)
+
+ ! cfra2D: Cloud Fraction
+ cfra2D(il, kl) = 0.5d0 * (1.d0 + err)
+
+ alpha = 1.d0 / (1.d0 + 1.349d7 * qsl / (tl * tl))
+ t1 = sigqt / sqrt(pi + pi) * exp(-min(argerf * argerf &
+ , argmax))
+ t2 = cfra2D(il, kl) * (qt - qsl)
+
+ ! cfraOK = 1.0 if cfra2D(il,kl) > cminHY
+ ! cfraOK = 0.0 otherwise
+ signFR = sign(unun, cfra2D(il, kl) - cminHY)
+ cfraOK = max(zero, signFR)
+
+ ! qw_new : Mesh Averaged Liquid Water Mixing Ratio
+ cfra2D(il, kl) = cfra2D(il, kl) * cfraOK * qHeNu1
+ qw_new = alpha * (t1 + t2) * cfraOK
+
+ dqw = qw_new - qw2D(il, kl)
+
+ ! Vectorisation of the Atmospheric Water Update
+ ! ~~~+-------------------------------------------+
+ ! | if (dqw > 0.) then |
+ ! | dqw = min(qv2D(il,kl), dqw) |
+ ! | else |
+ ! | dqw =-min(qw2D(il,kl),-dqw) |
+ ! | end if |
+ ! +-------------------------------------------+
+
+ signdq = sign(unun, dqw)
+ fac_qv = max(zero, signdq)
+ updatw = fac_qv * qv2D(il, kl) &
+ + (1.d0 - fac_qv) * qw2D(il, kl)
+#if(kk)
+ ! SCu Limitor
+ SCuLim = exp(min(0., 300. - tair2D(il, kl)))
+#endif
+ dqw = signdq * min(updatw, signdq * dqw) &
+ * qHeNu1
+#if(kk)
+ ! SCu Limitor
+ dqw = dqw * SCuLim
+ cfra2D(il, kl) = cfra2D(il, kl) * SCuLim
+#endif
+ ! Update of qv2D, qw2D and tair2D
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ qw2D(il, kl) = qw2D(il, kl) + dqw
+ dqw2D(il, kl) = dqw2D(il, kl) + dqw
+ qv2D(il, kl) = qv2D(il, kl) - dqw
+ tair2D(il, kl) = tair2D(il, kl) + r_LvCp * dqw
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'QwEvp', dqw, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wwevp(kl) = dqw
+#endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Delobbe: Condensation '
+ debugH(36:70) = ' '
+ proc_1 = 'dQw g/kg'
+ procv1 = dqw
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(05, kl) = dqw
+#endif
+ enddo
+ enddo
+ else
+ !===========================================================
+ ! Water Vapor Condensation / Evaporation
+ ! Reference: Emde and Kahlig 1989, Ann.Geoph. 7, p.407 (7)
+ ! --------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ dqw = 0.
+#endif
+ if(W2xyz1(il, kl) >= tsfo) then
+#if(EW)
+ ! ctr
+ if(W2xyz1(il, kl) > tsfo) then
+ mauxEW = mphy2D(il)
+ mauxEW(07:07) = 'W'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! qHeNu1 = 1.0 if W2xyz1(il,kl) > tsfo
+ ! qHeNu1 = 0.0 otherwise
+ signHN = sign(unun, W2xyz1(il, kl) - tsfo)
+ qHeNu1 = max(zero, signHN)
+
+ dpw = (qv2D(il, kl) - qvsw2D(il, kl) * rhcrHY) / &
+ (1.d0 + 1.349d7 * qvsw2D(il, kl) / &
+ (tair2D(il, kl) * tair2D(il, kl)))
+ ! 1.349e7=Lv*Lv*0.622/Cpa/Ra with Lv = 2500000 J/kg
+
+ dqw = dpw
+
+ ! Vectorisation of the Atmospheric Water Update
+ ! ~~+-------------------------------------------+
+ ! | if (dqw > 0.) then |
+ ! | dqw = min(qv2D(il,kl), dqw) |
+ ! | else |
+ ! | dqw =-min(qw2D(il,kl),-dqw) |
+ ! | end if |
+ ! +-------------------------------------------+
+
+ signdq = sign(unun, dqw)
+ fac_qv = max(zero, signdq)
+ updatw = fac_qv * qv2D(il, kl) &
+ + (1.d0 - fac_qv) * qw2D(il, kl)
+ dqw = signdq * min(updatw, signdq * dqw) &
+ * qHeNu1
+
+ ! Update of qv2D, qw2D and tair2D
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ qw2D(il, kl) = qw2D(il, kl) + dqw
+ dqw2D(il, kl) = dqw2D(il, kl) + dqw
+ qv2D(il, kl) = qv2D(il, kl) - dqw
+ tair2D(il, kl) = tair2D(il, kl) + r_LvCp * dqw
+ ! [Ls=2500000J/kg]/[Cp=1004J/kg/K]=2490.04
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'QwEvp', dqw, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wwevp(kl) = dqw
+#endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Emde and Kahlig: Water Vapor Conden'
+ debugH(36:70) = 'sation / Evaporation '
+ proc_1 = 'dQw g/kg'
+ procv1 = dqw
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(05, kl) = dqw
+#endif
+ enddo
+ enddo
+ endif
+
+ !===========================================================================
+
+ ! Fractional Cloudiness ! Guess may be computed (Ek&Mahrt91 fracSC=.T.)
+ ! ====================== ! Final value computed below
+
+ !!#sc if (fracld .and..not. fracSC) then
+ if(fracld) then
+ if(fraCEP) then
+ ! ECMWF Large Scale Cloudiness
+ ! ----------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ cfra2D(il, kl) = &
+ (qi2D(il, kl) + qw2D(il, kl) + qs2D(il, kl) * 0.33 &
+ * (1. - min(1., exp((tair2D(il, kl) - 258.15) * 0.1)))) &
+ / (0.02 * qvsw2D(il, kl))
+ cfra2D(il, kl) = min(1.000, cfra2D(il, kl))
+ cfra2D(il, kl) = max(0.001, cfra2D(il, kl)) &
+ * max(0., sign(1., &
+ qi2D(il, kl) + qw2D(il, kl) + qs2D(il, kl) - 3.E-9))
+ enddo
+ enddo
+ else
+ ! XU and Randall 1996, JAS 21, p.3099 (4)
+ ! ----------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qvs_wi = qvsw2D(il, kl)
+#if(wi)
+ qvs_wi = max(eps9, ((qi2D(il, kl) + qs2D(il, kl)) * qvsi2D(il, kl) &
+ + qw2D(il, kl) * qvsw2D(il, kl)) / &
+ max(eps9, qi2D(il, kl) + qs2D(il, kl) + qw2D(il, kl)))
+#endif
+ relhum = min(relCri, max(qv2D(il, kl), qv_MIN) / qvs_wi)
+ argexp = ((relCri - relhum) * qvs_wi)**0.49
+ argexp = min(100. * &
+ (qi2D(il, kl) + qw2D(il, kl) + qs2D(il, kl) * 0.33 &
+ * (1. - min(1., exp((tair2D(il, kl) - 258.15) * 0.1)))) &
+ / max(eps9, argexp), argmax)
+
+ cfra2D(il, kl) = (relhum**0.25) * (1. - exp(-argexp))
+ enddo
+ enddo
+ endif
+
+ else
+ !!#sc else if (.not.fracld) then
+ !!#sc if (fracSC) stop 'fracSC set up when fracld NOT'
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qcloud = qi2D(il, kl) + qw2D(il, kl)
+ if(qcloud > eps9) then
+
+ ! cfra2D(il,kl) = 1.0 if qcloud > eps9
+ ! cfra2D(il,kl) = 0.0 otherwise
+ signQW = sign(unun, qcloud - eps9)
+ cfra2D(il, kl) = max(zero, signQW)
+
+ endif
+ enddo
+ enddo
+
+ endif
+
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ do kl = mzhyd, klev
+ do il = 1, klon
+ debugH(1:35) = 'Fractional Cloudiness (XU .OR. CEP)'
+ debugH(36:70) = ' '
+ proc_1 = ' '
+ procv1 = 0.
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ enddo
+ enddo
+#endif
+
+ !===========================================================================
+
+ ! Autoconversion Processes (i.e., generation of precipitating particles)
+ ! ======================================================================
+
+ ! Cloud Droplets Autoconversion
+ ! Reference: Lin et al. (1983), JCAM 22, p.1076 (50)
+ ! --------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qraut = 0.0
+#endif
+ if(qw2D(il, kl) > eps9) then
+
+ ! AutoOK = 1.0 if qw2D(il,kl) > eps9
+ ! AutoOK = 0.0 otherwise
+ signAU = sign(unun, qw2D(il, kl) - eps9)
+ AutoOK = max(zero, signAU)
+
+ if(cfra2D(il, kl) > cminHY) then
+
+ ! ClouOK = 1.0 if cfra2D(il,kl) > cminHY
+ ! ClouOK = 0.0 otherwise
+ signFC = sign(unun, cfra2D(il, kl) - cminHY)
+ ClouOK = max(zero, signFC)
+
+ AutoOK = AutoOK * ClouOK
+#if(EW)
+ ! ctr
+ if(AutoOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(08:08) = 'r'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! Sundqvist (1988, Schlesinger, Reidel, p.433)
+ ! Autoconversion Scheme
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dqw = AutoOK * qw2D(il, kl) / &
+ qw00 / max(cminHY, cfra2D(il, kl))
+ praut = AutoOK * qw2D(il, kl) * csud * &
+ (1. - exp(-min(dqw * dqw, argmax))) &
+ / max(cminHY, cfra2D(il, kl))
+#if(LO)
+ ! Liou and Ou (1989, JGR 94, p. 8599) Autoconversion Scheme
+ ! Boucher et al. (1995, JGR 100, p.16395)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! ASTEX (Duynkerke&al.1995, JAS 52, p.2763)
+ ! (polluted air, Rogers&Yau 89, p.90)
+ ccnw2D(il, kl) = 1.2e+8
+ ccnw2D(il, kl) = 1.e+11
+ qwclou = qw2D(il, kl) / cfra2D(il, kl)
+ dmed0 = 4.5d0 * sigmaw * sigmaw
+ dmede = qwclou * rolv2D(il, kl) &
+ * 6.d0 / pi / ccnw2D(il, kl) / exp(dmed0)
+ dmed = exp(third * log(dmede))
+ dmed2 = dmed * dmed
+ dw0 = 8.d0 * sigmaw * sigmaw
+ dw4 = exp(dw0) * dmed2 * dmed2
+ rwbar = 0.5d0 * sqrt(sqrt(dw4))
+ ! heavi : Heaviside Function
+ signHV = sign(unun, rwbar - rcrilo)
+ heavi = max(zero, signHV)
+ praut = AutoOK * cfra2D(il, kl) * heavi * 4.09d6 * pi &
+ * ccnw2D(il, kl) * dw4 * qwclou
+#endif
+#if(LI)
+ ! Lin et al.(1983) Autoconversion Scheme
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dqw = AutoOK * (qw2D(il, kl) - qw00)
+ praut = dqw * dqw * dqw / &
+ (cc1 * dqw + 1000.d0 * cc2 / dd0)
+#endif
+ qraut = praut * xt
+ if(qraut > 0) qraut = qraut * min(0.9, (1. - cloud_magic))
+ qraut = min(qraut, qw2D(il, kl))
+ qw2D(il, kl) = qw2D(il, kl) - qraut
+ qr2D(il, kl) = qr2D(il, kl) + qraut
+
+#if(WQ)
+ write(6, *) 'QrAut', qraut, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wraut(kl) = qraut
+#endif
+
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983) Autoconversion Sch'
+ debugH(36:70) = 'eme '
+ proc_1 = 'Qraut g/kg'
+ procv1 = qraut
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(06, kl) = qraut
+#endif
+ enddo
+ enddo
+
+ ! Conversion from Cloud Ice Crystals to Snow Flakes
+ ! Reference: Levkov et al. 1992, Contr.Atm.Phys. 65, p.41
+ ! ---------------------------------------------------------
+
+ if(LevkovAUTO) then
+
+ ! Depositional Growth: Ice Crystals => Snow Flakes (BDEPIS)
+ ! Reference: Levkov et al. 1992, Contr.Atm.Phys. 65, p.41 (28)
+ ! --------------------------------------------------------------
+
+ if(LevkovAUTX) then
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsaut = 0.0
+#endif
+ if(qi2D(il, kl) > eps9) then
+
+ ! AutoOK = 1.0 if qi2D(il,kl) > eps9
+ ! AutoOK = 0.0 otherwise
+ signAU = sign(unun, qi2D(il, kl) - eps9)
+ AutoOK = max(zero, signAU)
+
+ if(ccni2D(il, kl) > 1.) then
+
+ ! ClouOK = 1.0 if ccni2D(il,kl) > 1.
+ ! ClouOK = 0.0 otherwise
+ signCC = sign(unun, ccni2D(il, kl) - 1.)
+ ClouOK = max(zero, signCC)
+
+ AutoOK = AutoOK * ClouOK
+ qiOK = AutoOK * qi2D(il, kl)
+
+ ! Pristine Ice Crystals Diameter
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! qid : Pristine Ice Crystals Diameter
+ ! Levkov et al. 1992,
+ ! Contr. Atm. Phys. 65, (5) p.37
+ ! where 6/(pi*ro_I)**1/3 ~ 0.156
+ qid = 0.156 * exp(third * log(thous * rolv2D(il, kl) &
+ * max(eps9, qi2D(il, kl)) &
+ / max(unun, ccni2D(il, kl))))
+
+ ! Deposition Time Scale
+ ! ~~~~~~~~~~~~~~~~~~~~~
+ sat = max(epsq, qv2D(il, kl)) / W2xyz5(il, kl)
+ ! 0.702e12 ~ 0.702e12 = (2.8345e+6)**2/0.0248/461.5
+ ! Ls_H2O **2/Ka /Rw
+ ! Dv = 2.36e-2 = 2.36e-5 * 10.**3
+#if(a1)
+ a1saut = max(eps9, sat - 1.) / &
+ (0.702e12 / (tair2D(il, kl) * tair2D(il, kl)) &
+ + 1. / (2.36e-2 * rolv2D(il, kl) * qv2D(il, kl) * sat))
+#endif
+ ! Dv = 2.36e-2 = 2.36e-5 * 10.**3
+ xtsaut = 0.125 * (qsd0 * qsd0 - qid * qid) &
+ * (0.702e12 / (tair2D(il, kl) * tair2D(il, kl)) &
+ + 1.0 / (2.36e-2 * rolv2D(il, kl) &
+ * max(epsq, qv2D(il, kl)) * sat))
+
+ ! Deposition
+ ! ~~~~~~~~~~
+ qsaut = xt * qiOK * (sat - 1.) / xtsaut
+ qsaut = (1. - cloud_magic) * qsaut
+ qsaut = min(qi2D(il, kl), qsaut)
+ qsaut = max(-qs2D(il, kl), qsaut)
+
+ if(.not.isnan(qsaut)) then
+ qi2D(il, kl) = qi2D(il, kl) - qsaut
+ qs2D(il, kl) = qs2D(il, kl) + qsaut
+ endif
+
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983) Depositional Growt'
+ debugH(36:70) = 'h '
+ proc_1 = 'Qsaut g/kg'
+ procv1 = qsaut
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(07, kl) = qsaut
+#endif
+ enddo
+ enddo
+ endif
+
+ ! Ice Crystals Aggregation => Snow Flakes (BAGRIS)
+ ! Reference: Levkov et al. 1992, Contr.Atm.Phys. 65, p.41 (31)
+ ! --------------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsaut = 0.0
+ xtsaut = 0.0
+#endif
+ if(qi2D(il, kl) > eps9) then
+ ! AutoOK = 0.0 otherwise
+ ! AutoOK = 1.0 if qi2D(il,kl) > eps9
+ signAU = sign(unun, qi2D(il, kl) - eps9)
+ AutoOK = max(zero, signAU)
+
+ if(ccni2D(il, kl) > 1.) then
+
+ ! ClouOK = 1.0 if ccni2D(il,kl) > 1.
+ ! ClouOK = 0.0 otherwise
+ signCC = sign(unun, ccni2D(il, kl) - 1.)
+ ClouOK = max(zero, signCC)
+
+ AutoOK = AutoOK * ClouOK
+ qiOK = AutoOK * qi2D(il, kl)
+#if(EW)
+ if(AutoOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(09:09) = 's'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! Pristine Ice Crystals Diameter
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ !qid : Pristine Ice Crystals Diameter
+ ! Levkov et al. 1992
+ ! Contr. Atm. Phys. 65, (5) p.37
+ ! where [6/(pi*ro_I)]**1/3 ~ 0.156
+ qid = 0.156 * exp(third * log(thous * rolv2D(il, kl) &
+ * max(eps9, qi2D(il, kl)) &
+ / max(unun, ccni2D(il, kl))))
+
+ ! Time needed for Ice Crystals Diameter to reach Snow Diameter Threshold
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ c1saut = max(eps9, qiOK) * rolv2D(il, kl) * 35. &
+ * exp(third * log(rolv2D(il, klev) / &
+ rolv2D(il, kl)))
+
+ ! qi fully used if xtsaut<xt
+ xtsaut = -6.d0 * log(qid / qsd0) / c1saut
+ xtsaut = max(xt, xtsaut)
+#if(nt)
+ ! Time needed for Ice Crystals Diameter
+ ! to reach Snow Diameter Threshold
+ ! ~(ALTERNATE PARAMETERIZATION)~
+ xtsaut = -2.0 * (3.0 * log(qid / qsd0) &
+ + log(max(qi2D(il, kl), eps9))) / c1saut
+ xtsaut = max(eps9, xtsaut)
+#endif
+ ! Aggregation
+ ! ~~~~~~~~~~~
+ qsaut = xt * qiOK / xtsaut
+ if(qsaut > 0) qsaut = qsaut * (1. - cloud_magic)
+ qsaut = min(qi2D(il, kl), qsaut)
+ qsaut = max(-qs2D(il, kl), qsaut)
+ if(.not.isnan(qsaut)) then
+ qi2D(il, kl) = qi2D(il, kl) - qsaut
+ qs2D(il, kl) = qs2D(il, kl) + qsaut
+
+ ! Decrease of Ice Crystals Number (BAGRII)
+ ! Reference: Levkov et al. 1992
+ ! Contr.Atm.Phys. 65, p.41 (34)
+ ! ----------------------------------------
+ ccni2D(il, kl) = ccni2D(il, kl) * exp(-0.5 * c1saut * xt)
+#if(WQ)
+ write(6, *) 'QsAut', qsaut, &
+ ' Qi', qi2D(il, kl), &
+ ' CcnI', ccni2D(il, kl), itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wsaut(kl) = qsaut
+#endif
+ endif
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983) Ice Crystals Aggre'
+ debugH(36:70) = 'gation '
+ proc_1 = 'xtsaut sec'
+ procv1 = xtsaut
+ proc_2 = 'Qsaut g/kg'
+ procv2 = qsaut
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(07, kl) = qsaut + debugV(07, kl)
+#endif
+ enddo
+ enddo
+ !=======================================================================
+ else if(EmdeKa) then
+ ! Ice Crystals Autoconversion => Snow Flakes
+ ! Reference: Lin et al. 1983, JCAM 22, p.1070 (21)
+ ! Lin et al. 1983, JCAM 22, p.1074 (38)
+ ! Emde and Kahlig 1989, Ann.Geoph. 7, p. 408 (18)
+ ! ----------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsaut = 0.0
+ cnsaut = 0.0
+#endif
+ if(qi2D(il, kl) >= qi00) then
+#if(EW)
+ if(qi2D(il, kl) >= qi00) then
+ mauxEW = mphy2D(il)
+ mauxEW(09:09) = 's'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ex1 = 0.025d0 * W2xyz1(il, kl) ! W2 = t?[K]
+ psaut = 0.001d0 * (qi2D(il, kl) - qi00) * exp(ex1)
+ qsaut = psaut * xt
+ qsaut = qsaut * (1. - cloud_magic)
+ qsaut = max(qsaut, zero)
+ qsaut = min(qsaut, qi2D(il, kl))
+ cnsaut = ccni2D(il, kl) * qsaut &
+ / max(qi00, qi2D(il, kl))
+ ccni2D(il, kl) = ccni2D(il, kl) - cnsaut
+ qi2D(il, kl) = qi2D(il, kl) - qsaut
+ qs2D(il, kl) = qs2D(il, kl) + qsaut
+#if(WQ)
+ write(6, *) 'QsAut', qsaut, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wsaut(kl) = qsaut
+#endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Emde and Kahlig Ice Crystals Autoc'
+ debugH(36:70) = 'onversion '
+ proc_1 = 'Qsaut g/kg'
+ procv1 = qsaut
+ proc_2 = 'cnsaut/e15'
+ procv2 = cnsaut * 1.e-18
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(07, kl) = qsaut
+#endif
+ enddo
+ enddo
+ else
+ ! Sundqvist (1988, Schlesinger, Reidel, p. 433) Autoconversion Scheme
+ ! --------------------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsaut = 0.0
+ cnsaut = 0.0
+#endif
+ if(qi2D(il, kl) > eps9) then
+
+ ! AutoOK = 1.0 if qi2D(il,kl) > eps9
+ ! AutoOK = 0.0 otherwise
+ signAU = sign(unun, qi2D(il, kl) - eps9)
+ AutoOK = max(zero, signAU)
+
+ dqi = AutoOK * qi2D(il, kl) / qi0S
+#if(mf)
+ dqi = dqi / max(cminHY, cfra2D(il, kl))
+#endif
+ psaut = AutoOK * qi2D(il, kl) * csud &
+ * (1. - exp(-dqi * dqi))
+#if(mf)
+ psaut = psaut * max(cminHY, cfra2D(il, kl))
+#endif
+ qsaut = psaut * xt
+ qsaut = (1. - cloud_magic) * qsaut
+ qsaut = min(qi2D(il, kl), qsaut)
+ qsaut = max(zero, qsaut)
+ cnsaut = ccni2D(il, kl) * qsaut &
+ / max(qi2D(il, kl), eps9)
+ ccni2D(il, kl) = ccni2D(il, kl) - cnsaut
+ qi2D(il, kl) = qi2D(il, kl) - qsaut
+ qs2D(il, kl) = qs2D(il, kl) + qsaut
+
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Sundqvist (1988) Ice Crystals Autoc'
+ debugH(36:70) = 'onversion '
+ proc_1 = 'Qsaut g/kg'
+ procv1 = qsaut
+ proc_2 = 'cnsaut/e15'
+ procv2 = cnsaut * 1.e-18
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(07, kl) = qsaut
+#endif
+ enddo
+ enddo
+ endif
+
+#if(qg)
+ ! Ice Crystals Autoconversion => Graupels
+ ! ---------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ if(qi2D(il, kl) >= qg00) then
+ ex1 = 0.090 * W2xyz1(il, kl)
+ pgaut = 0.001 * (qi2D(il, kl) - qg00) * exp(ex1)
+ qgaut = pgaut * xt
+ qgaut = max(qgaut, zero)
+ qgaut = min(qgaut, qi2D(il, kl))
+ qi2D(il, kl) = qi2D(il, kl) - qgaut
+ qg2D(il, kl) = qg2D(il, kl) + qgaut
+ endif
+ enddo
+ enddo
+#endif
+ !===========================================================================
+
+ ! Accretion Processes (i.e. increase in size of precipitating particles
+ ! ==================== through a collision-coalescence process)===
+ ! ==============================================
+
+ ! Accretion of Cloud Droplets by Rain
+ ! Reference: Lin et al. 1983, JCAM 22, p.1076 (51)
+ ! Emde and Kahlig 1989, Ann.Geoph. 7, p. 407 (10)
+ ! ----------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qracw = 0.0
+#endif
+ if(qw2D(il, kl) > eps9) then
+
+ ! WbyR_w = 1.0 if qw2D(il,kl) > eps9
+ ! WbyR_w = 0.0 otherwise
+ sign_W = sign(unun, qw2D(il, kl) - eps9)
+ WbyR_w = max(zero, sign_W)
+
+ if(W2xyz3(il, kl) > eps9) then
+
+ ! WbyR_r = 1.0 if W2xyz3(il,kl) > eps9
+ ! WbyR_r = 0.0 otherwise
+ sign_R = sign(unun, W2xyz3(il, kl) - eps9)
+ WbyR_r = max(zero, sign_R)
+
+ WbyROK = WbyR_w * WbyR_r
+#if(EW)
+ ! ctr
+ if(WbyROK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(10:10) = 'r'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ pracw = 3104.28d0 * cnor * W2xyz6(il, kl) &
+ * qw2D(il, kl) / exp(3.8d0 * log(W2xyz7(il, kl)))
+ ! 3104.28 = a pi Gamma[3+b] / 4
+ ! where a = 842. and b = 0.8
+ qracw = pracw * xt * WbyROK
+ if(qracw > 0) qracw = qracw * min(0.9, (1. - cloud_magic))
+ qracw = min(qracw, qw2D(il, kl))
+
+ qw2D(il, kl) = qw2D(il, kl) - qracw
+ qr2D(il, kl) = qr2D(il, kl) + qracw
+
+#if(WQ)
+ write(6, *) 'Qracw', qracw, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wracw(kl) = qracw
+#endif
+
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Accretion of Clou'
+ debugH(36:70) = 'd Droplets by Rain '
+ proc_1 = 'Qracw g/kg'
+ procv1 = qracw
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(08, kl) = qracw
+#endif
+ enddo
+ enddo
+
+ ! Accretion of Cloud Droplets by Snow Flakes
+ ! Reference: Lin et al. 1983, JCAM 22, p.1070 (24)
+ ! ----------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ snoA = 0.0
+#endif
+
+ if(qw2D(il, kl) > eps9) then
+
+
+#if(cn)
+ ! psacw : taken into account in the snow melting process
+ ! (if positive temperatures)
+ ! 9.682 = c pi Gamma[3+d] / 4
+ ! where c = 4.836 and d = 0.25
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Graupellike Snow Flakes of Hexagonal Type)
+ cnos = min(2.e8, &
+ cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ psacw(il, kl) = 9.682d0 * cnos * W2xyz6(il, kl) &
+ * qw2D(il, kl) / exp(3.25d0 * log(W2xyz8(il, kl)))
+#if(up)
+ ! psacw : taken into account in the snow melting process
+ ! (if positive temperatures)
+ ! 3517. = c pi Gamma[3+d] / 4
+ ! where c = 755.9 and d = 0.99
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Unrimed Side Planes)
+ psacw(il, kl) = 3517. * cnos * W2xyz6(il, kl) &
+ * qw2D(il, kl) / exp(3.99d0 * log(W2xyz8(il, kl)))
+#endif
+#if(ur)
+ ! psacw : taken into account in the snow melting process
+ ! (if positive temperatures)
+ ! 27.73 = c pi Gamma[3+d] / 4
+ ! where c = 11.718and d = 0.41
+ ! (Locatelli and Hobbs, 1974, JGR: table 1 p.2188:
+ ! Aggregates of unrimed radiating assemblages)
+ psacw(il, kl) = 27.73 * cnos * W2xyz6(il, kl) &
+ * qw2D(il, kl) / exp(3.41d0 * log(W2xyz8(il, kl)))
+#endif
+
+ ! WbyS_w = 1.0 if qw2D(il,kl) > eps9
+ ! WbyS_w = 0.0 otherwise
+ sign_W = sign(unun, qw2D(il, kl) - eps9)
+ WbyS_w = max(zero, sign_W)
+
+ if(W2xyz4(il, kl) > eps9) then
+
+ ! WbyS_s = 1.0 if W2xyz4(il,kl) > eps9
+ ! WbyS_s = 0.0 otherwise
+ sign_S = sign(unun, W2xyz4(il, kl) - eps9)
+ WbyS_s = max(zero, sign_S)
+
+ WbySOK = WbyS_w * WbyS_s
+#if(EW)
+ ! ctr
+ if(WbySOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(11:11) = 's'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+
+ qsacw = psacw(il, kl) * xt * WbySOK
+ if(qsacw > 0) qsacw = qsacw * min(0.9, (1. - cloud_magic))
+ qsacw = min(qsacw, qw2D(il, kl))
+
+ ! Fact_R = 1.0 if tair2D(il,kl) > TfSnow
+ ! Fact_R = 0.0 otherwise
+ sign_T = sign(unun, tair2D(il, kl) - TfSnow)
+ Fact_R = max(zero, sign_T)
+ if(.not.isnan(qsacw)) then
+ qw2D(il, kl) = qw2D(il, kl) - qsacw
+ qr2D(il, kl) = qr2D(il, kl) + Fact_R * qsacw
+ SnoA = (1.d0 - Fact_R) * qsacw
+ qs2D(il, kl) = qs2D(il, kl) + SnoA
+ ! Negative Temp. => Latent Heat is released by Freezing
+ tair2D(il, kl) = tair2D(il, kl) + r_LcCp * SnoA
+
+ ! Full Debug
+ ! ~~~~~~~~~~
+#if(WQ)
+ write(6, *) 'Qsacw', qsacw, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wsacw(kl) = qsacw
+#endif
+ endif
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Accretion of Cloud'
+ debugH(36:70) = ' Droplets by Snow Particles '
+ proc_1 = 'Qsacw g/kg'
+ procv1 = SnoA
+ proc_3 = ' '
+ procv2 = 0.
+ proc_2 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(09, kl) = SnoA
+#endif
+ enddo
+ enddo
+
+#if(qg)
+ ! Accretion of Cloud Droplets by Graupels (Dry Growth Mode)
+ ! Reference: Lin et al. 1983, JCAM 22, p.1075 (40)
+ ! Emde and Kahlig 1989, Ann.Geoph. 7, p. 407 (~20)
+ ! -----------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ if(qw2D(il, kl) > eps9) then
+ ! WbyG_w = 1.0 if qw2D(il,kl) > eps9
+ ! WbyG_w = 0.0 otherwise
+ sign_W = sign(unun, qw2D(il, kl) - eps9)
+ WbyG_w = max(zero, sign_W)
+ if(qg2D(il, kl) > eps9) then
+ ! WbyG_g = 1.0 if qg2D(il,kl) > eps9
+ ! WbyG_g = 0.0 otherwise
+ sign_G = sign(unun, qg2D(il, kl) - eps9)
+ WbyG_g = max(zero, sign_G)
+ WbyGOK = WbyG_w * WbyG_g
+ if(tair2D(il, kl) < TfSnow) then
+ ! Fact_G = 1.0 if tair2D(il,kl) > TfSnow
+ ! Fact_G = 0.0 otherwise
+ sign_T = -sign(unun, tair2D(il, kl) - TfSnow)
+ Fact_G = max(zero, sign_T)
+ ! pgacw = ???
+ qgacw = pgacw * xt * WbyGOK
+ qgacw = min(qgacw, qw2D(il, kl))
+ qw2D(il, kl) = qw2D(il, kl) - qgacw
+ qg2D(il, kl) = qg2D(il, kl) + qgacw
+ tair2D(il, kl) = tair2D(il, kl) + r_LcCp * gacw
+ endif
+ endif
+ endif
+ enddo
+ enddo
+#endif
+ ! Accretion of Cloud Ice by Snow Particles
+ ! Reference: Lin et al. 1983, JCAM 22, p.1070 (22)
+ ! ----------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsaci = 0.0
+ cnsaci = 0.0
+#endif
+ if(qi2D(il, kl) > eps9) then
+
+ ! CbyS_c = 1.0 if qi2D(il,kl) > eps9
+ ! CbyS_c = 0.0 otherwise
+ sign_C = sign(unun, qi2D(il, kl) - eps9)
+ CbyS_c = max(zero, sign_C)
+
+ if(W2xyz4(il, kl) > eps9) then
+
+ ! CbyS_s = 1.0 if W2xyz4(il,kl) > eps9
+ ! CbyS_s = 0.0 otherwise
+ sign_S = sign(unun, W2xyz4(il, kl) - eps9)
+ CbyS_s = max(zero, sign_S)
+
+ if(tair2D(il, kl) < TfSnow) then
+
+ ! CbyS_T = 1.0 if tair2D(il,kl) < TfSnow
+ ! CbyS_T = 0.0 otherwise
+ sign_T = -sign(unun, tair2D(il, kl) - TfSnow)
+ CbyS_T = max(zero, sign_T)
+
+ CbySOK = CbyS_c * CbyS_s * CbyS_T
+#if(EW)
+ ! ctr
+ if(CbySOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(12:12) = 's'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! efc : Collection Efficiency
+ ! Lin et al. 1983 JCAM 22 p.1070 (23)
+ efc = exp(0.025d0 * W2xyz1(il, kl))
+#if(cn)
+ cnos = min(2.e8, &
+ cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ psaci = efc * 9.682d0 * cnos * W2xyz6(il, kl) &
+ * qi2D(il, kl) / exp(3.25d0 * log(W2xyz8(il, kl)))
+#if(up)
+ psaci = efc * 3517.d0 * cnos * W2xyz6(il, kl) &
+ * qi2D(il, kl) / exp(3.99d0 * log(W2xyz8(il, kl)))
+#endif
+#if(ur)
+ psaci = efc * 27.73d0 * cnos * W2xyz6(il, kl) &
+ * qi2D(il, kl) / exp(3.41d0 * log(W2xyz8(il, kl)))
+#endif
+ qsaci = psaci * xt * CbySOK
+ if(qsaci > 0) qsaci = qsaci * (1. - cloud_magic)
+ qsaci = min(qsaci, qi2D(il, kl))
+
+ cnsaci = ccni2D(il, kl) * qsaci / &
+ max(qi2D(il, kl), eps9)
+ ccni2D(il, kl) = ccni2D(il, kl) - cnsaci
+ qi2D(il, kl) = qi2D(il, kl) - qsaci
+ qs2D(il, kl) = qs2D(il, kl) + qsaci
+
+#if(WQ)
+ write(6, *) 'Qsaci', qsaci, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wsaci(kl) = qsaci
+#endif
+
+ endif
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Accretion of Clou'
+ debugH(36:70) = 'd Ice by Snow Particles '
+ proc_1 = 'Qsaci g/kg'
+ procv1 = qsaci
+ proc_2 = 'CNsaci/e15'
+ procv2 = cnsaci * 1.e-18
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(10, kl) = qsaci
+#endif
+ enddo
+ enddo
+
+#if(qg)
+ ! Accretion of Cloud Ice by Graupel (Cloud Ice Sink)
+ ! Reference: Lin et al. 1983, JCAM 22, p.1075 (41)
+ ! Emde and Kahlig 1989, Ann.Geoph. 7, p. 407 (~19)
+ ! -----------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ if(qw2D(il, kl) > eps9) then
+ ! CbyG_c = 1.0 if qi2D(il,kl) > eps9
+ ! = 0.0 otherwise
+ sign_C = sign(unun, qi2D(il, kl) - eps9)
+ CbyG_c = max(zero, sign_C)
+ if(qg2D(il, kl) > eps9) then
+ ! CbyG_g = 1.0 if qg2D(il,kl) > eps9
+ ! CbyG_g = 0.0 otherwise
+ sign_G = sign(unun, qg2D(il, kl) - eps9)
+ CbyG_g = max(zero, sign_G)
+ if(tair2D(il, kl) < TfSnow) then
+ ! Fact_G = 1.0 if tair2D(il,kl) < TfSnow
+ ! Fact_G = 0.0 otherwise
+ sign_T = -sign(unun, tair2D(il, kl) - TfSnow)
+ Fact_G = max(zero, sign_T)
+ CbyGOK = CbyG_c * CbyG_g * Fact_G
+ ! pgaci = ???
+ qgaci = pgaci * xt * CbyGOK
+ qgaci = min(qgaci, qi2D(il, kl))
+ qi2D(il, kl) = qi2D(il, kl) - qgaci
+ qg2D(il, kl) = qg2D(il, kl) + qgaci
+ endif
+ endif
+ endif
+ enddo
+ enddo
+#endif
+
+ ! Accretion of Cloud Ice by Rain (Cloud Ice Sink)
+ ! Reference: Lin et al. 1983, JCAM 22, p.1071 (25)
+ ! ------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qraci = 0.0
+ qiacr = 0.0
+#endif
+ if(qi2D(il, kl) > eps9) then
+ ! CbyR_c = 1.0 if qi2D(il,kl) > eps9
+ ! CbyR_c = 0.0 otherwise
+ sign_C = sign(unun, qi2D(il, kl) - eps9)
+ CbyR_c = max(zero, sign_C)
+ if(W2xyz3(il, kl) > eps9) then
+ ! CbyR_r = 1.0 if W2xyz3(il,kl) > eps9
+ ! CbyR_r = 0.0 otherwise
+ sign_R = sign(unun, W2xyz3(il, kl) - eps9)
+ CbyR_r = max(zero, sign_R)
+ if(tair2D(il, kl) < TfSnow) then
+ ! CbyR_T = 1.0 if tair2D(il,kl) < TfSnow
+ ! CbyR_T = 0.0 otherwise
+ sign_T = -sign(unun, tair2D(il, kl) - TfSnow)
+ CbyR_T = max(zero, sign_T)
+
+ CbyROK = CbyR_c * CbyR_r * CbyR_T
+#if(EW)
+ ! ctr
+ if(CbyROK > epsi) then
+ mauxEW = mphy2D(il)
+ if(mauxEW(13:13) == 's' .or. mauxEW(13:13) == 'A') then
+ mauxEW(13:13) = 'A'
+ else
+ mauxEW(13:13) = 'r'
+ endif
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ praci = 3104.28d0 * cnor * W2xyz6(il, kl) &
+ * qi2D(il, kl) / exp(3.8d0 * log(W2xyz7(il, kl)))
+ qraci = praci * xt * CbyROK
+ if(qraci > 0) qraci = qraci * (1. - cloud_magic)
+ qraci = min(qraci, qi2D(il, kl))
+ cnraci = ccni2D(il, kl) * qraci / &
+ max(qi2D(il, kl), eps9)
+ ccni2D(il, kl) = ccni2D(il, kl) - cnraci
+ qi2D(il, kl) = qi2D(il, kl) - qraci
+#if(qg)
+ ! CAUTION : Graupels Formation is not taken into account
+ ! This could be a reasonable assumption for Antarctica
+ ! ctr
+ if(qr2D(il, kl) > 1.e-4) then
+ qg2D(il, kl) = qg2D(il, kl) + qraci
+ else
+#endif
+ qs2D(il, kl) = qs2D(il, kl) + qraci
+#if(qg)
+ endif
+#endif
+
+#if(WQ)
+ write(6, *) 'Qraci', qraci, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wraci(kl) = qraci
+#endif
+
+ ! Accretion of Rain by Cloud Ice (Rain Sink)
+ ! Reference: Lin et al. 1983, JCAM 22, p.1071 (26)
+ ! ------------------------------------------------
+#if(EW)
+ ! ctr
+ if(CbyROK > epsi) then
+ mauxEW = mphy2D(il)
+ if(mauxEW(13:13) == 'r' .or. mauxEW(13:13) == 'A') then
+ mauxEW(13:13) = 'A'
+ else
+ mauxEW(13:13) = 's'
+ endif
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! Lin et al, 1983, JAM,p1071: mi:Ice Crystal Mass
+ piacr = 4.1e20 * cnor * W2xyz6(il, kl) &
+ * qi2D(il, kl) / exp(6.8d0 * log(W2xyz7(il, kl)))
+ ! 4.1e20 = a pi**2 rhow/mi Gamma[6+b] / 24
+ ! where a=842., rhow=1000, mi=4.19e-13
+ ! and b = 0.8
+ qiacr = piacr * xt * CbyROK
+ qiacr = min(qiacr, qr2D(il, kl))
+ qr2D(il, kl) = qr2D(il, kl) - qiacr
+ tair2D(il, kl) = tair2D(il, kl) + r_LcCp * qiacr
+#if(qg)
+ ! CAUTION : Graupels Formation is not taken into account
+ ! This could be a reasonable assumption for Antarctica
+ ! ctr
+ if(qr2D(il, kl) > 1.e-4) then
+ qg2D(il, kl) = qg2D(il, kl) + qiacr
+ else
+#endif
+ qs2D(il, kl) = qs2D(il, kl) + qiacr
+#if(qg)
+ endif
+#endif
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'Qiacr', qiacr, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wiacr(kl) = qiacr
+#endif
+ endif
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Accretion of Clou'
+ debugH(36:70) = 'd Ice by Rain '
+ proc_1 = 'Qraci g/kg'
+ procv1 = qraci
+ proc_2 = 'qiacr g/kg'
+ procv2 = qiacr
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(11, kl) = qiacr
+#endif
+ enddo
+ enddo
+
+ ! Accretion of Rain by Snow Flakes
+ ! Accretion of Snow Flakes by Rain
+ ! Reference: Lin et al. 1983, JCAM 22, p.1071 (27)
+ ! Lin et al. 1983, JCAM 22, p.1071 (28)
+ ! Emde and Kahlig 1989, Ann.Geoph. 7, p. 408 (~21)
+ ! -----------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ psacr(il, kl) = 0.d0
+ qsacr = 0.d0
+#if(wH)
+ qraci = 0.0d0
+ qracsS = 0.0d0
+ qsacrR = 0.0d0
+#endif
+ if(W2xyz3(il, kl) > eps9) then
+ ! RbyS_r = 1.0 if W2xyz3(il,kl) > eps9
+ ! RbyS_r = 0.0 otherwise
+ sign_R = sign(unun, W2xyz3(il, kl) - eps9) ! W2xyz3: Qr
+ RbyS_r = max(zero, sign_R)
+ if(W2xyz4(il, kl) > eps9) then
+ ! RbyS_s = 1.0 if W2xyz4(il,kl) > eps9
+ ! RbyS_s = 0.0 otherwise
+ sign_S = sign(unun, W2xyz4(il, kl) - eps9) ! W2xyz4: Qs
+ RbyS_s = max(zero, sign_S)
+
+ RbySOK = RbyS_r * RbyS_s
+#if(EW)
+ if(CbyROK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(14:14) = 'A'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! Accretion of Rain by Snow --> Snow | W2xyz7 : lambda_r
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ | W2xyz8 : lambda_s
+ flS = (5.0d0 / (W2xyz8(il, kl) * W2xyz8(il, kl) * W2xyz7(il, kl)) &
+ + 2.0d0 / (W2xyz8(il, kl) * W2xyz7(il, kl) * W2xyz7(il, kl)) &
+ + 0.5d0 / (W2xyz7(il, kl) * W2xyz7(il, kl) * W2xyz7(il, kl))) &
+ / (W2xyz8(il, kl) * W2xyz8(il, kl) * W2xyz8(il, kl) * W2xyz8(il, kl))
+#if(cn)
+ cnos = min(2.e8, &
+ cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ pracs = 986.96d-3 * (cnor * cnos / rolv2D(il, kl)) &
+ * abs(vr(il, kl) - vs(il, kl)) * flS
+ ! 986.96: pi**2 * rhos
+ ! (snow density assumed equal to 100 kg/m3)
+ qracs = pracs * xt * RbySOK
+ qracs = min(qracs, qr2D(il, kl))
+#if(WQ)
+ write(6, *) 'Qracs', qracs, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wracs(kl) = qracs
+#endif
+ ! Accretion of Snow by Rain --> Rain
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! SbyR_r = 1.0 if W2xyz3(il,kl) > 1.e-4
+ ! SbyR_r = 0.0 otherwise
+ sign_R = sign(unun, W2xyz3(il, kl) - 1.e-4)
+ SbyR_r = max(zero, sign_R)
+
+ ! SbyR_s = 1.0 if W2xyz4(il,kl) > 1.e-4
+ ! SbyR_s = 0.0 otherwise
+ sign_S = sign(unun, W2xyz4(il, kl) - 1.e-4)
+ SbyR_s = max(zero, sign_S)
+
+ SbyROK = max(SbyR_r, SbyR_s)
+
+ if(SbyROK > epsi) then
+ flR = (5.d0 / (W2xyz7(il, kl) * W2xyz7(il, kl) * W2xyz8(il, kl)) &
+ + 2.d0 / (W2xyz7(il, kl) * W2xyz8(il, kl) * W2xyz8(il, kl)) &
+ + 0.5d0 / (W2xyz8(il, kl) * W2xyz8(il, kl) * W2xyz8(il, kl))) &
+ / (W2xyz7(il, kl) * W2xyz7(il, kl) * W2xyz7(il, kl) * W2xyz7(il, kl))
+
+ psacr(il, kl) = 9869.6d-3 * (cnor * cnos / rolv2D(il, kl)) &
+ * abs(vr(il, kl) - vs(il, kl)) * flR
+ ! 9869.6: pi**2 * rhow
+ ! (water density assumed equal to 1000 kg/m3)
+ qsacr = psacr(il, kl) * xt * RbySOK * SbyROK
+ qsacr = min(qsacr, qs2D(il, kl))
+
+#if(WQ)
+ write(6, *) 'Qsacr', qsacr, itexpe, il, kl
+#endif
+
+#if(WH)
+ if(il == ilmm) wsacr(kl) = qsacr
+#endif
+ else
+ psacr(il, kl) = 0.d0
+ qsacr = 0.d0
+ endif
+
+ ! CbyR_T = 1.0 if tair2D(il,kl) < TfSnow
+ ! = 0.0 otherwise
+ sign_T = -sign(unun, tair2D(il, kl) - TfSnow)
+ CbyR_T = max(zero, sign_T)
+
+ qracsS = qracs * CbyR_T
+ qsacrR = qsacr * (1.d0 - CbyR_T)
+
+ qr2D(il, kl) = qr2D(il, kl) - qracsS
+#if(qg)
+ ! CAUTION : Graupel Formation is not taken into Account
+ if(W2xyz3(il, kl) < 1.e-4 .and. W2xyz4(il, kl) < 1.e-4) then
+#endif
+ qs2D(il, kl) = qs2D(il, kl) + qracsS
+#if(qg)
+ else
+ qs2D(il, kl) = qs2D(il, kl) - qracsS
+ qg2D(il, kl) = qg2D(il, kl) + qsacrS + qracsS
+ endif
+#endif
+ tair2D(il, kl) = tair2D(il, kl) + qracsS * r_LcCp
+ qr2D(il, kl) = qr2D(il, kl) + qsacrR
+ qs2D(il, kl) = qs2D(il, kl) - qsacrR
+ tair2D(il, kl) = tair2D(il, kl) - qsacrR * r_LcCp
+ endif
+ endif
+
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Accretion of Snow'
+ debugH(36:70) = '(Rain) by Rain(Snow) '
+ proc_1 = 'Qracs g/kg'
+ procv1 = qracsS
+ proc_2 = 'Qsacr g/kg'
+ procv2 = qsacrR
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ include 'MAR_HY.Debug'
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(12, kl) = qracsS - qsacrR
+#endif
+ enddo
+ enddo
+
+ ! Accretion of Snow by Graupels
+ ! Reference: Lin et al. 1983, JCAM 22, p.1071 (29)
+ ! ----------------------------------------------------------
+
+ ! #if(qg)
+ ! do il=1,klon
+ ! do kl=mzhyd,klev
+ !
+ ! if (W2xyz0(il,kl) > eps9) then
+ !
+ ! ! SbyG_g = 1.0 if W2xyz0(il,kl) > eps9
+ ! ! SbyG_g = 0.0 otherwise
+ ! sign_G = sign(unun,W2xyz0(il,kl) - eps9)
+ ! SbyG_g = max(zero,sign_G)
+ !
+ ! if (W2xyz4(il,kl) > eps9) then
+ !
+ ! ! SbyG_s = 1.0 if W2xyz4(il,kl) > eps9
+ ! ! SbyG_s = 0.0 otherwise
+ ! sign_S = sign(unun,W2xyz4(il,kl) - eps9)
+ ! SbyG_s = max(zero,sign_S)
+ !
+ ! SbyGOK = SbyG_g * SbyG_s
+ !
+ ! ! efc : Collection Efficiency
+ ! ! Lin et al. 1983 JCAM 22 p.1072 (30)
+ ! efc = exp(0.090*W2xyz1(il,kl))
+ !
+ ! flg=exp(-6.0d0*log(W2xyz8(il,kl)) &
+ ! *(5.0/W2xyz9(il,kl) &
+ ! +2.0*W2xyz8(il,kl)/(W2xyz9(il,kl)*W2xyz9(il,kl)) &
+ ! +0.5*W2xyz8(il,kl)* W2xyz8(il,kl) &
+ ! /exp(3.0d0*log(W2xyz9(il,kl))))
+ ! #if(cn)
+ ! cnos = min(2.e8 , &
+ ! cnos2*exp(-.12*min(0.,W2xyz1(il,kl))))
+ ! #endif
+ ! pgacs = 986.96d-3*(cnog*cnos/rolv2D(il,kl)) &
+ ! * abs(vg(il,kl)-vs(il,kl))*flg*efc
+ ! ! 986.96: pi**2 * rhog
+ ! ! (graupel densitity assumed equal to snow density)
+ ! qgacs = pgacs * xt * SbyGOK
+ ! qgacs = min(qgacs,qs2D(il,kl))
+ ! qg2D(il,kl) = qg2D(il,kl) + qgacs
+ ! qs2D(il,kl) = qs2D(il,kl) - qgacs
+ !
+ ! end if
+ ! end if
+ !
+ ! end do
+ ! end do
+ ! #endif
+
+ ! Accretion of Rain by Graupels (Dry Growth Mode)
+ ! Reference: Lin et al. 1983, JCAM 22, p.1075 (42)
+ ! ------------------------------------------------
+ ! #if(qg)
+ ! do kl=mzhyd,klev
+ ! do il=1,klon
+ !
+ ! if (W2xyz0(il,kl) > eps9) then
+ !
+ ! ! RbyG_g = 0.0 otherwise
+ ! ! RbyG_g = 1.0 if W2xyz0(il,kl) > eps9
+ ! sign_G = sign(unun,W2xyz0(il,kl) - eps9)
+ ! RbyG_g = max(zero,sign_G)
+ !
+ ! if (W2xyz3(il,kl) > eps9) then
+ !
+ ! ! RbyG_r = 0.0 otherwise
+ ! ! RbyG_r = 1.0 if W2xyz3(il,kl) > eps9
+ ! sign_R = sign(unun,W2xyz3(il,kl) - eps9)
+ ! RbyG_r = max(zero,sign_R)
+ !
+ ! if (tair2D(il,kl) < TfSnow) then
+ !
+ ! ! Fact_G = 0.0 otherwise
+ ! ! Fact_G = 1.0 if tair2D(il,kl) < TfSnow
+ ! sign_T = -sign(unun,tair2D(il,kl) - TfSnow)
+ ! Fact_G = max(zero,sign_T)
+ !
+ ! RbyGOK = RbyG_g * RbyG_s * Fact_G
+ !
+ ! flg=exp(-6.0d0*log(W2xyz8(il,kl)) &
+ ! *(5.0/W2xyz9(il,kl) &
+ ! +2.0*W2xyz8(il,kl)/(W2xyz9(il,kl)*W2xyz9(il,kl)) &
+ ! +0.5*W2xyz8(il,kl)* W2xyz8(il,kl)) &
+ ! /exp(3.0d0*log(W2xyz9(il,kl))))
+ ! #if(cn)
+ ! cnos = min(2.e8 , &
+ ! cnos2*exp(-.12*min(0.,W2xyz1(il,kl))))
+ ! #endif
+ ! pgacr = 986.96d-3*(cnog*cnos/rolv2D(il,kl)) &
+ ! * abs(vg(i,kl) - vr(il,kl))*flg
+ ! qgacr = pgacr * xt * RbyGOK
+ ! qgacr = min(qgacr,qr2D(il,kl))
+ ! qg2D(il,kl) = qg2D(il,kl) + qgacr
+ ! qr2D(il,kl) = qr2D(il,kl) - qgacr
+ ! tair2D(il,kl) = tair2D(il,kl) + r_LcCp*qgacr
+ !
+ ! end if
+ ! end if
+ ! end if
+ !
+ ! end do
+ ! end do
+ ! #endif
+
+#if(qg)
+ ! Graupels Wet Growth Mode
+ ! Reference: Lin et al. 1983, JCAM 22, p.1075 (43)
+ ! ----------------------------------------------------------
+ ! TO BE ADDED !
+#endif
+
+ ! Microphysical Processes affecting Precipitating Cloud Particles
+ ! ===================================================================
+
+ ! Rain Drops Evaporation ============
+ ! Reference: Lin et al. 1983, JCAM 22, p.1077 (52)
+ ! ----------------------------------------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qrevp = 0.0
+#endif
+ if(W2xyz3(il, kl) > eps9) then
+ ! W2xyz3 : old Rain Concentration
+
+ ! Evap_r = 1.0 if W2xyz3(il,kl) > eps9
+ ! Evap_r = 0.0 otherwise
+ sign_R = sign(unun, W2xyz3(il, kl) - eps9)
+ Evap_r = max(zero, sign_R)
+
+ EvapOK = Evap_r
+
+#if(EW)
+ if(EvapOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(15:15) = 'v'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ ! sr : grid scale saturation humidity
+ sr = qv2D(il, kl) / (rhcrHY * qvsw2D(il, kl))
+
+ if(sr < unun) then
+ ! Evap_q = 1.0 if sr < unun
+ ! Evap_q = 0.0 otherwise
+ sign_Q = -sign(unun, sr - unun)
+ Evap_q = max(zero, sign_Q)
+
+ EvapOK = EvapOK * Evap_q
+
+ almr = 0.78d0 / (W2xyz7(il, kl) * W2xyz7(il, kl)) &
+ + 3940.d0 * sqrt(W2xyz6(il, kl)) &
+ / exp(2.9d0 * log(W2xyz7(il, kl)))
+ ab = 5.423d11 / (tair2D(il, kl) * tair2D(il, kl)) &
+ + 1.d0 / (1.875d-2 * rolv2D(il, kl) * qvsw2D(il, kl))
+
+ prevp = 2 * pi * (1.d0 - sr) * cnor * almr / ab
+ qrevp = prevp * xt
+ qrevp = min(qrevp, qr2D(il, kl))
+
+ ! supersaturation is not allowed to occur
+ qrevp = min(qrevp, rhcrHY * qvsw2D(il, kl) - qv2D(il, kl))
+
+ ! condensation is not allowed to occur
+ qrevp = max(qrevp, zero) * EvapOK
+
+ qr2D(il, kl) = qr2D(il, kl) - qrevp
+ dqw2D(il, kl) = dqw2D(il, kl) - qrevp
+ qv2D(il, kl) = qv2D(il, kl) + qrevp
+ tair2D(il, kl) = tair2D(il, kl) - r_LvCp * qrevp
+ qrevp2D(il, kl) = qrevp
+ ! Full Debug
+ ! ~~~~~~~~~~
+#if(WQ)
+ write(6, *) 'Qrevp', qrevp, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wrevp(kl) = qrevp
+#endif
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Rain Drops Evapor'
+ debugH(36:70) = 'ation '
+ proc_1 = 'Qrevp g/kg'
+ procv1 = qrevp
+ proc_2 = 'R.Hum [%]'
+ procv2 = sr * 0.1
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ include 'MAR_HY.Debug'
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(13, kl) = -qrevp
+#endif
+ enddo
+ enddo
+
+ ! (Deposition on) Snow Flakes (Sublimation)
+ ! Reference: Lin et al. 1983, JCAM 22, p.1072 (31)
+ ! ----------------------------------------------------------
+
+ ! #if(BS)
+ ! do il=1,klon
+ ! hlat2D(il,1) = 0.d0
+ ! end do
+ ! #endif
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qssub = 0.0
+#endif
+ if(W2xyz4(il, kl) > eps9) then
+ ! W2xyz4 : old Snow F. Concentration
+
+ ! Evap_s = 1.0 if W2xyz4(il,kl) > eps9
+ ! Evap_s = 0.0 otherwise
+ sign_S = sign(unun, W2xyz4(il, kl) - eps9)
+ Evap_s = max(zero, sign_S)
+
+#if(EW)
+ if(Evap_s > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(16:16) = 'V'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+
+ si = qv2D(il, kl) / W2xyz5(il, kl)
+
+ alms = 0.78d0 / (W2xyz8(il, kl) * W2xyz8(il, kl)) &
+ + 238.d0 * sqrt(W2xyz6(il, kl)) &
+ / exp(2.625d0 * log(W2xyz8(il, kl)))
+ ab = 6.959d11 / (tair2D(il, kl) * tair2D(il, kl)) &
+ + 1.d0 / (1.875d-2 * rolv2D(il, kl) * W2xyz5(il, kl))
+
+#if(cn)
+ cnos = min(2.e8, &
+ cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ pssub = 2 * pi * (1.d0 - si) * cnos * alms / (1.d3 * rolv2D(il, kl) * ab)
+ qssub = pssub * xt
+
+ dqamx = W2xyz5(il, kl) - qv2D(il, kl)
+
+ ! Depo_s = 1.0 if si > unun
+ ! Depo_s = 0.0 otherwise
+ sign_S = sign(unun, si - unun)
+ Depo_s = max(zero, sign_S)
+
+ ! qssub < 0 ... Deposition
+ ! qssub > 0 ... Sublimation
+ qssub = max(qssub, dqamx) * Depo_s &
+ + min(min(qssub, qs2D(il, kl)), dqamx) * (1.d0 - Depo_s)
+
+ qssub = qssub * Evap_s
+
+ qs2D(il, kl) = qs2D(il, kl) - qssub
+ dqi2D(il, kl) = dqi2D(il, kl) - qssub
+ qv2D(il, kl) = qv2D(il, kl) + qssub
+ tair2D(il, kl) = tair2D(il, kl) - r_LsCp * qssub
+ qssub2D(il, kl) = qssub
+ ! #if(BS)
+ ! hlat2D(il ,1) = hlat2D(il ,1) + qssub * rolv2D(il,kl) &
+ ! *(gpmi2D(il,kl)-gpmi2D(il,kl+1))*grvinv
+ ! #endif
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'Qssub', qssub, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wssub(kl) = -qssub
+#endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): (Deposition on) S'
+ debugH(36:70) = 'now Particles (Sublimation) '
+ proc_1 = 'Qssub g/kg'
+ procv1 = qssub
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ include 'MAR_HY.Debug'
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(14, kl) = -qssub
+#endif
+ enddo
+ enddo
+
+#if(qg)
+ ! Graupels Sublimation
+ ! Reference: Lin et al. 1983, JCAM 22, p.1076 (46)
+ ! ----------------------------------------------------------
+ ! TO BE ADDED !
+#endif
+ ! Snow Flakes Melting PSMLT
+ ! Reference: Lin et al. 1983, JCAM 22, p.1072 (32)
+ ! ----------------------------------------------------------
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsmlt = 0.0
+#endif
+ if(W2xyz4(il, kl) > eps9) then
+ ! W2xyz4 : old Snow Fl.Concentration
+
+ ! SnoM_s = 1.0 if W2xyz4(il,kl) > eps9
+ ! SnoM_s = 0.0 otherwise
+ sign_S = sign(unun, W2xyz4(il, kl) - eps9)
+ SnoM_s = max(zero, sign_S)
+
+ if(W2xyz1(il, kl) > 0.) then
+ ! W2xyz1 : old Celsius Temperature
+
+ ! SnoM_T = 1.0 if W2xyz1(il,kl) > 0.
+ ! SnoM_T = 0.0 otherwise
+ sign_T = sign(unun, W2xyz1(il, kl) - 0.)
+ SnoM_T = max(zero, sign_T)
+
+ SnoMOK = SnoM_s * SnoM_T
+#if(EW)
+ if(SnoMOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(17:17) = 'r'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ alms = 0.78 / (W2xyz8(il, kl) * W2xyz8(il, kl)) &
+ + 238. * sqrt(W2xyz6(il, kl)) &
+ / exp(2.625d0 * log(W2xyz8(il, kl)))
+#if(cn)
+ cnos = min(2.e8, &
+ cnos2 * exp(-.12 * min(0., W2xyz1(il, kl))))
+#endif
+ xCoef = 1.904d-8 * cnos * alms * r_LcCp / rolv2D(il, kl)
+ ! 1.904e-8: 2 pi / Lc /[10.**3 =rho Factor]
+
+ ACoef = 0.0250d0 * xCoef &
+ + (psacw(il, kl) + psacr(il, kl)) * r_LcCp / 78.8d0
+ ! 78.8 : Lc /[Cpw=4.187e3 J/kg/K]
+
+ Bcoef = 62.34d+3 * rolv2D(il, kl) * &
+ (qv2D(il, kl) - W2xyz5(il, kl)) &
+ * xCoef
+ Bcoef = min(-eps9, Bcoef)
+
+ Tc = (tair2D(il, kl) - TfSnow - ACoef / Bcoef) * exp(-ACoef * xt)
+ qsmlt = (tair2D(il, kl) - TfSnow - Tc) / r_LcCp
+ qsmlt = max(qsmlt, 0.) * SnoMOK
+ qsmlt = min(qsmlt, qs2D(il, kl))
+
+ if(tair2D(il,kl)-TfSnow>5) qsmlt=max(qsmlt,qs2D(il,kl)/4.) ! no snow > 5°C
+
+ ! #if(XF)
+ ! ! this options increases the conversion of Snowfall to rainfall
+ ! alms = 0.78d0 /(W2xyz8(il,kl)*W2xyz8(il,kl)) &
+ ! + 238.d0 * sqrt(W2xyz6(il,kl)) &
+ ! /exp(2.625d0*log(W2xyz8(il,kl)))
+ ! akps = 0.025d0 *W2xyz1(il,kl) &
+ ! + 46.875d3 *rolv2D(il,kl) *(qv2D(il,kl)-W2xyz5(il,kl))
+ ! ! 46.875 : Lv*[psiv=1.875e-5m2/s]
+ !
+ ! psmlt = 1.904d-8*cnos*akps*alms/rolv2D(il,kl) &
+ ! -(psacw(il,kl) + psacr(il,kl)) *W2xyz1(il,kl) / 78.8d0
+ ! ! 1.904e-8: 2 pi / Lc /[10.**3 =rho Factor]
+ ! ! Lc /[Cpw=4.187e3 J/kg/K] = 78.8
+ ! qsmlt = psmlt * xt * SnoMOK
+ ! qsmlt = max(qsmlt,zero)
+ ! qsmlt = min(qsmlt,qs2D(il,kl))
+ ! #endif
+ qs2D(il, kl) = qs2D(il, kl) - qsmlt
+ qr2D(il, kl) = qr2D(il, kl) + qsmlt
+ tair2D(il, kl) = tair2D(il, kl) - r_LcCp * qsmlt
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'Qsmlt', qsmlt, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wsmlt(kl) = qsmlt
+#endif
+
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Snow Particles Me'
+ debugH(36:70) = 'lting '
+ proc_1 = 'Qsmlt g/kg'
+ procv1 = qsmlt
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ include 'MAR_HY.Debug'
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(15, kl) = -qsmlt
+#endif
+ enddo
+ enddo
+#if(qg)
+ ! Graupels Melting
+ ! Reference: Lin et al. 1983, JCAM 22, p.1076 (47)
+ ! ----------------------------------------------------------
+ ! TO BE ADDED !
+#endif
+ ! Rain Freezing
+ ! Reference: Lin et al. 1983, JCAM 22, p.1075 (45)
+ ! ----------------------------------------------------------
+ ! **CAUTION**: Graupel Formation TO BE ADDED !
+ do kl = mzhyd, klev
+ do il = 1, klon
+#if(wH)
+ qsfr = 0.0
+#endif
+ if(W2xyz3(il, kl) > eps9) then
+ ! W2xyz3 : old Rain Concentration
+ ! Freezr = 1.0 if W2xyz3(il,kl) > eps9
+ ! Freezr = 0.0 otherwise
+ sign_R = sign(unun, W2xyz3(il, kl) - eps9)
+ Freezr = max(zero, sign_R)
+ if(W2xyz1(il, kl) < 0.) then
+ ! W2xyz1 : old Celsius Temperature
+ ! FreezT = 1.0 if W2xyz1(il,kl) < 0.
+ ! FreezT = 0.0 otherwise
+ sign_T = -sign(unun, W2xyz1(il, kl) - 0.)
+ FreezT = max(zero, sign_T)
+ FrerOK = Freezr * FreezT
+#if(EW)
+ if(FrerOK > epsi) then
+ mauxEW = mphy2D(il)
+ mauxEW(19:19) = 's'
+ mphy2D(il) = mauxEW
+ endif
+#endif
+ psfr = 1.974d4 * cnor &
+ / (rolv2D(il, kl) * exp(7.d0 * log(W2xyz7(il, kl)))) &
+ * (exp(-0.66d0 * W2xyz1(il, kl)) - 1.d0)
+ qsfr = psfr * xt * FrerOK
+ qsfr = min(qsfr, qr2D(il, kl))
+
+ if(tair2D(il,kl)-TfSnow<-5) qsfr=max(qsfr,qr2D(il,kl)/4.) ! no rain < -5C
+
+ qr2D(il, kl) = qr2D(il, kl) - qsfr
+ qs2D(il, kl) = qs2D(il, kl) + qsfr
+ ! CAUTION : graupel production is included into snow production
+ ! proposed modification in line below.
+ ! #if(qg)
+ ! qg2D(il,kl) = qg2D(il,kl) + qsfr
+ ! #endif
+ tair2D(il, kl) = tair2D(il, kl) + r_LcCp * qsfr
+#if(WQ)
+ ! Full Debug
+ ! ~~~~~~~~~~
+ write(6, *) 'Qsfre', qsfr, itexpe, il, kl
+#endif
+#if(WH)
+ if(il == ilmm) wsfre(kl) = qsfr
+#endif
+ endif
+ endif
+#if(wH)
+ ! Debug
+ ! ~~~~~
+ debugH(1:35) = 'Lin et al.(1983): Rain Freezing '
+ debugH(36:70) = ' '
+ proc_1 = 'Qsfr g/kg'
+ procv1 = qsfr
+ proc_2 = ' '
+ procv2 = 0.
+ proc_3 = ' '
+ procv3 = 0.
+ proc_4 = ' '
+ procv4 = 0.
+ include 'MAR_HY.Debug'
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) &
+ debugV(16, kl) = qsfr
+#endif
+
+ enddo
+ enddo
+
+ ! Debug (Summary)
+ ! ~~~~~~~~~~~~~~~
+#if(wH)
+ do kl = mzhyd, klev
+ do il = 1, klon
+ if(i_fvv(il) == i0fvv .and. j_fvv(il) == j0fvv) then
+ if(kl == mzhyd) then
+ write(6, 6022)
+ 6022 format(/, 'HYDmic STATISTICS=================')
+ write(6, 6026)
+ 6026 format(' T_Air Qv Qw g/kg Qi g/kg CLOUDS % '// &
+ ' Qs g/kg Qr g/kg'// &
+ ' Qi+ E.K.'// &
+ ' Qi+ Mey.'// &
+ ' Qi- Sub.'// &
+ ' Qi- Mlt.'// &
+ ' Qw+ Cds.'// &
+ ' Qraut r+'// &
+ ' Qsaut s+'// &
+ ' Qracw r+')
+ endif
+ write(6, 6023) kl, &
+ tair2D(il, kl) - TfSnow, &
+ 10.**3 * qv2D(il, kl), &
+ 10.**3 * qw2D(il, kl), &
+ 10.**3 * qi2D(il, kl), &
+ 10.**2 * cfra2D(il, kl), &
+ 10.**3 * qs2D(il, kl), &
+ 10.**3 * qr2D(il, kl), &
+ (10.**3 * debugV(kv, kl), kv = 1, 8)
+ 6023 format(i3, f6.1, f5.2, 2f9.6, f9.1, 2f9.3, 8f9.6)
+ if(kl == klev) then
+ write(6, 6026)
+ write(6, *) ' '
+ write(6, 6024)
+ 6024 format(8x, 'Z [km]'// &
+ ' RH.w.[%]'// &
+ ' RH.i.[%]'//9x// &
+ ' Vss cm/s'// &
+ ' Vrr cm/s'// &
+ ' Qsacw s+'// &
+ ' Qsaci s+'// &
+ ' Qiacr r+'// &
+ ' Qracs ds'// &
+ ' Qrevp w-'// &
+ ' Qssub s-'// &
+ ' Qsmlt s-'// &
+ ' Qsfr s+')
+ do nl = mzhyd, klev
+ write(6, 6025) nl, zsigma(nl) * 1.e-3, &
+ 10.**2 * qv2D(il, nl) / qvsw2D(il, nl), &
+ 10.**2 * qv2D(il, nl) / qvsi2D(il, nl), &
+ 10.**2 * vs(il, nl), &
+ 10.**2 * vr(il, nl), &
+ (10.**3 * debugV(kv, nl), kv = 9, 16)
+ 6025 format(i3, f11.3, 2f9.1, 9x, 2f9.1, 8f9.6)
+ enddo
+ write(6, 6024)
+ write(6, *) ' '
+ endif
+
+ endif
+
+ enddo
+ enddo
+#endif
+
+#if(EW)
+ ! Vertical Integrated Energy and Water Content
+ ! ============================================
+ do il = 1, klon
+ enr11D(il) = 0.d0
+ wat11D(il) = 0.d0
+
+ do kl = 1, klev
+ enr11D(il) = enr11D(il) &
+ + (tair2D(il, kl) &
+ - (qw2D(il, kl) + qr2D(il, kl)) * r_LvCp &
+ - (qi2D(il, kl) + qs2D(il, kl)) * r_LsCp) * dsigm1(kl)
+ wat11D(il) = wat11D(il) &
+ + (qv2D(il, kl) &
+ + qw2D(il, kl) + qr2D(il, kl) &
+ + qi2D(il, kl) + qs2D(il, kl)) * dsigm1(kl)
+ enddo
+ enr11D(il) = enr11D(il) * pst2Dn(il) * grvinv
+ ! wat11D [m] contains implicit factor 10.**3 [kPa-->Pa] /ro_Wat
+ wat11D(il) = wat11D(il) * pst2Dn(il) * grvinv
+
+ enddo
+#endif
+
+ ! Precipitation
+ ! =============
+
+ ! Hydrometeors Fall Velocity
+ ! --------------------------
+
+ ! Pristine Ice Crystals Diameter and Fall Velocity
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do kl = mzhyd, klev
+ do il = 1, klon
+
+ if(qi2D(il, kl) > eps9) then
+
+ ! Sedi_c = 1.0 if qi2D(il,kl) > eps9
+ ! Sedi_c = 0.0 otherwise
+ sign_Q = sign(unun, qi2D(il, kl) - eps9)
+ Sedi_c = max(zero, sign_Q)
+
+ if(ccni2D(il, kl) > 1.) then
+
+ ! Sedicc = 1.0 if ccni2D(il,kl) > 1.
+ ! Sedi_c = 0.0 otherwise
+ signCC = sign(unun, ccni2D(il, kl) - 1.)
+ Sedicc = max(zero, signCC)
+
+ SediOK = Sedi_c * Sedicc
+
+ ! qid : Pristine Ice Crystals Diameter,
+ ! Levkov et al. 1992, Contr. Atm. Phys. 65, (5) p.37
+ ! where 6/(pi*ro_I)**1/3 ~ 0.16
+ qid = 0.16d0 * exp(third * log(thous * rolv2D(il, kl) &
+ * max(eps9, qi2D(il, kl)) / max(ccni2D(il, kl), unun)))
+ ! vi : Terminal Fall Velocity for Pristine Ice Crystals
+ ! Levkov et al. 1992, Contr. Atm. Phys. 65, (4) p.37
+ vi(il, kl) = SediOK * 7.d2 * qid &
+ * exp(0.35d0 * log(rolv2D(il, klev) / rolv2D(il, kl)))
+ else
+ vi(il, kl) = 0.d0
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! Set Up of the Numerical Scheme
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(VW)
+ vwmx = 0.d0
+#endif
+ ! vrmx = 0.d0
+ ! vsmx = 0.d0
+ vimx = 0.d0
+#if(EW)
+ do il = 1, klon
+ ! watf1D : Water Flux (Atmosphere --> Surface)
+ watf1D(il) = 0.d0
+ enddo
+#endif
+
+ ! Snow and Rain Fall Velocity (Correction)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do kl = mzhyd, klev
+ do il = 1, klon
+ vi(il, kl) = vi(il, kl) * qi2D(il, kl) / max(qi2D(il, kl), eps9)
+ vs(il, kl) = vs(il, kl) * qs2D(il, kl) / max(qs2D(il, kl), eps9)
+#if(VW)
+ vw(il, kl) = vw(il, kl) * qw2D(il, kl) / max(qw2D(il, kl), eps9)
+#endif
+ vr(il, kl) = vr(il, kl) * qr2D(il, kl) / max(qr2D(il, kl), eps9)
+ vimx = max(vi(il, kl), vimx)
+ ! vsmx = max(vs(il,kl),vsmx)
+ ! vrmx = max(vr(il,kl),vrmx)
+#if(VW)
+ vwmx = max(vw(il, kl), vwmx)
+#endif
+#if(WH)
+ if(vsmx > vmmx) then
+ vmmx = vsmx
+ ilmmi = il
+ endif
+ if(vrmx > vmmi) then
+ vmmi = vrmx
+ ilmmi = il
+ endif
+#endif
+ enddo
+ enddo
+
+ ! dzmn = 10000.
+ ! do il=1,klon
+ ! dzmn = min(dzmn,(gplv2D(il,mz1)-gplv2D(il,mz))*grvinv)
+ ! end do
+
+ ! Rain Drops Precipitation (Implicit Scheme)
+ ! -------------------------------------------
+
+ do il = 1, klon
+ W2xyz8(il, mzhyd - 1) = 0.
+ enddo
+
+ ! Precipitation Mass & Flux
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~
+ do kl = mzhyd, klev
+ do il = 1, klon
+ ! Air Mass [mWE]
+ W2xyz1(il, kl) = pst2Dn(il) * dsigm1(kl) * grvinv
+ ! Flux Fact. [mWE]
+ W2xyz6(il, kl) = xt * vr(il, kl) * rolv2D(il, kl)
+ enddo
+
+ do il = 1, klon
+ ! Rain Mass From abov.
+ W2xyz5(il, kl) = qr2D(il, kl) * W2xyz1(il, kl) &
+ + 0.5 * W2xyz8(il, kl - 1)
+ if(kl < kk_pp) then
+ ! Corr. Bug
+ W2xyz7(il, kl) = W2xyz6(il, kl) / W2xyz1(il, kl)
+ else
+ ! Var. Fact. Flux Limi.
+ W2xyz7(il, kl) = min(2., W2xyz6(il, kl) / W2xyz1(il, kl))
+ endif
+ enddo
+
+ do il = 1, klon
+ ! Mass Loss
+ W2xyz8(il, kl) = W2xyz5(il, kl) * W2xyz7(il, kl) &
+ / (1. + W2xyz7(il, kl) * 0.5)
+ enddo
+
+ do il = 1, klon
+ ! From abov.
+ W2xyz5(il, kl) = W2xyz5(il, kl) - W2xyz8(il, kl) &
+ + 0.5 * W2xyz8(il, kl - 1)
+
+ ! Cooling from above precipitating flux
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ tair2D(il, kl) = (tair2D(il, kl) * W2xyz1(il, kl) &
+ + tair2D(il, kl - 1) * W2xyz8(il, kl - 1)) &
+ / (W2xyz1(il, kl) + W2xyz8(il, kl - 1))
+ enddo
+
+ do il = 1, klon
+ qr2D(il, kl) = W2xyz5(il, kl) / W2xyz1(il, kl)
+ rnf2D(il, kl) = rnf2D(il, kl) + W2xyz8(il, kl)
+ ! evp2D : Net Evap. Mass [mWE]
+ evp2D(il, kl) = evp2D(il, kl) + qrevp2D(il, kl) * W2xyz1(il, kl)
+ enddo
+ enddo
+
+ ! Precipitation reaching the Surface
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do il = 1, klon
+ ! dwat contains an implicit factor 10**3 [kPa->Pa]/ro_Wat[kg/m2->m w.e.]
+ dwat = W2xyz8(il, klev)
+ ratio_temp = (tair2D(il, klev - 1) + tair2D(il, klev - 2) + &
+ tair2D(il, klev - 3) + tair2D(il, klev - 4)) / 4.
+ ratio_prec = dwat
+ ! ratio_rfsf : -1C => snow ; 0C => rain
+ ratio_rfsf = max(0., min(1., (ratio_temp - rain_snow_limit) / 2.))
+ ! rain2D : rain precipitation height since start of run [m]
+ rain2D(il) = rain2D(il) + ratio_prec * ratio_rfsf
+ ! snow2D : snow precipitation height since start of run [m]
+ snow2D(il) = snow2D(il) + ratio_prec * (1. - ratio_rfsf)
+#if(EW)
+ watf1D(il) = watf1D(il) - dwat
+#endif
+ ! prec2D: rain precipitation height [m]
+ ! is reset to zero after included in water reservoir
+ prec2D(il) = prec2D(il) + dwat
+ enddo
+ dwat = 0.0
+
+#if(VW)
+ ! Droplets Precipitation
+ ! ----------------------
+ ! normally, 0.5 is sufficient to take into account truncation effect
+ itmx = int(1.d0 + xt * vwmx / dzmn)
+ itmx = max(1, itmx)
+ xtmn = xt / itmx
+
+ ! Precipitation reaching the Surface
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do it = 1, itmx
+ do il = 1, klon
+ ! dwat contains an implicit factor 10**3[kPa->Pa]/ro_Wat[kg/m2->m w.e.]
+ dwat = vw(il, klev) * qw2D(il, klev) * rolv2D(il, klev) * xtmn
+
+ ! rain2D : rain precipitation height since start of run [m]
+ rain2D(il) = rain2D(il) + dwat
+
+ watf1D(il) = watf1D(il) - dwat
+
+ ! prec2D : rain precipitation height [m]
+ ! is reset to zero after included in water reservoir
+ ! (cfr. routine SRFfrm_XXX)
+ prec2D(il) = prec2D(il) + dwat
+ enddo
+
+ ! Precipitation elsewhere
+ ! ~~~~~~~~~~~~~~~~~~~~~~~
+ do kl = klev, mzhyd + 1, -1
+ do il = 1, klon
+ W2xyz1(il, kl) = qw2D(il, kl) * pst2Dn(il) * dsigm1(kl) &
+ + gravit * xtmn * (qw2D(il, kl - 1) * vw(il, kl - 1) * rolv2D(il, kl - 1) &
+ - qw2D(il, kl) * vw(il, kl) * rolv2D(il, kl))
+ enddo
+ enddo
+
+ do il = 1, klon
+ W2xyz1(il, mzhyd) = qw2D(il, mzhyd) * pst2Dn(il) * dsigm1(mzhyd) &
+ - gravit * xtmn * qw2D(il, mzhyd) * vw(il, mzhyd) * rolv2D(il, mzhyd)
+ enddo
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qw2D(il, kl) = W2xyz1(il, kl) / (pst2Dn(il) * dsigm1(kl))
+ enddo
+ enddo
+
+ enddo
+#endif
+
+ ! Snow Flakes Precipitation (Implicit Scheme)
+ ! -------------------------------------------
+ do il = 1, klon
+ W2xyz8(il, mzhyd - 1) = 0.
+ enddo
+
+ ! Precipitation Mass & Flux
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~
+ do kl = mzhyd, klev
+ do il = 1, klon
+ ! Air Mass [mWE]
+ W2xyz1(il, kl) = pst2Dn(il) * dsigm1(kl) * grvinv
+ ! Flux Fact. [mWE]
+ W2xyz6(il, kl) = xt * vs(il, kl) * rolv2D(il, kl)
+ enddo
+
+ do il = 1, klon
+ ! Snow Mass From above
+ W2xyz5(il, kl) = qs2D(il, kl) * W2xyz1(il, kl) &
+ + 0.5 * W2xyz8(il, kl - 1)
+ if(kl < kk_pp) then
+ ! Corr. Bug
+ W2xyz7(il, kl) = W2xyz6(il, kl) / W2xyz1(il, kl)
+ else ! for blowing snow
+ ! Var. Fact. Flux Limit
+ W2xyz7(il, kl) = &
+ min(2., W2xyz6(il, kl) / W2xyz1(il, kl))
+ ! Var. Fact. Flux Limi.
+#if(BS)
+ W2xyz7(il, kl) = &
+ min(min(2., 0.5 + (klev - kl) * 0.5), &
+ W2xyz6(il, kl) / W2xyz1(il, kl))
+#endif
+ endif
+ enddo
+
+ do il = 1, klon
+ ! Mass Loss
+ W2xyz8(il, kl) = W2xyz5(il, kl) * W2xyz7(il, kl) / &
+ (1. + W2xyz7(il, kl) * 0.5)
+ enddo
+ do il = 1, klon
+ ! From abov.
+ W2xyz5(il, kl) = W2xyz5(il, kl) - W2xyz8(il, kl) &
+ + 0.5 * W2xyz8(il, kl - 1)
+
+ ! Cooling from above precipitating flux
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ tair2D(il, kl) = &
+ (tair2D(il, kl) * W2xyz1(il, kl) &
+ + tair2D(il, kl - 1) * W2xyz8(il, kl - 1)) &
+ / (W2xyz1(il, kl) + W2xyz8(il, kl - 1))
+ enddo
+
+ do il = 1, klon
+ qs2D(il, kl) = W2xyz5(il, kl) / W2xyz1(il, kl)
+ snf2D(il, kl) = snf2D(il, kl) + W2xyz8(il, kl)
+ ! sbl2D : Sublimation Mass [mWE]
+ sbl2D(il, kl) = sbl2D(il, kl) + max(zero, qssub2D(il, kl)) * W2xyz1(il, kl)
+ ! dep2D : Condensation Mass [mWE]
+ dep2D(il, kl) = dep2D(il, kl) + max(zero, -qssub2D(il, kl)) * W2xyz1(il, kl)
+ ! smt2D = UV*Qs*mass_air*dt
+ ! qs2D * W2xyz1 : Integrated Mass Transp. [ton/m]
+ smt2D(il, kl) = smt2D(il, kl) + &
+ qs2D(il, kl) * W2xyz1(il, kl) &
+ * sqrt((uair2D(il, kl)**2) + (vair2D(il, kl)**2)) &
+ * xt
+ !Atm. Sublim. ratio [kg/kg]
+ qssbl2D(il, kl) = qssbl2D(il, kl) + qssub2D(il, kl)
+ enddo
+ enddo
+
+ ! Precipitation reaching the Surface
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do il = 1, klon
+ ! dsno contains an implicit factor 10**3 [kPa->Pa]/ro_Wat[kg/m2->m w.e.]
+ dsno = W2xyz8(il, klev)
+
+ ! snow2D : snow precipitation height since start of run [m]
+ snow2D(il) = snow2D(il) + dsno
+#if(EW)
+ watf1D(il) = watf1D(il) - dsno
+#endif
+ ! snoh2D: snow precipitation height [m]
+ ! is reset to zero after included in snow cover
+ ! (cfr. routine SRFfrm_sno)
+ snoh2D(il) = snoh2D(il) + dsno
+ enddo
+ dsno = 0.
+
+ ! Pristine Ice Crystals Precipitation
+ ! -----------------------------------
+
+ ! itmx = int(1.d0 + xt * vimx / dzmn) cXF 04/2022
+ ! normally, 0.5 is sufficient to take into account truncation effect
+ !XF itmx = max(1,itmx)
+ itmx = 1
+ ! XF, 20200309: could be very slow with some compilors
+ xtmn = xt / itmx
+
+ ! Precipitation reaching the Surface
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! XF, 20200309: qi <0 if vimx>>
+
+ if(vimx > eps9) then
+ do it = 1, itmx
+ do il = 1, klon
+ ! dsno contains an implicit factor 10**3
+ ! [kPa->Pa]/ro_Wat[kg/m2->m w.e.]
+ dsno = vi(il, klev) * qi2D(il, klev) * rolv2D(il, klev) * xtmn
+
+ ! snow2D : snow precipitation height since start of run [m]
+ crys2D(il) = crys2D(il) + dsno
+ snow2D(il) = snow2D(il) + dsno
+
+#if(EW)
+ watf1D(il) = watf1D(il) - dsno
+#endif
+
+ ! snoh2D : snow precipitation height [m]
+ ! is reset to zero after included in snow cover
+ ! (cfr. routine SRFfrm_sno)
+ snoh2D(il) = snoh2D(il) + dsno
+ enddo
+
+ ! Precipitation elsewhere
+ ! ~~~~~~~~~~~~~~~~~~~~~~~
+ do kl = klev, mzhyd + 1, -1
+ do il = 1, klon
+ W2xyz1(il, kl) = qi2D(il, kl) * pst2Dn(il) * dsigm1(kl) &
+ + gravit * xtmn * (qi2D(il, kl - 1) * &
+ vi(il, kl - 1) * rolv2D(il, kl - 1) &
+ - qi2D(il, kl) * vi(il, kl) * rolv2D(il, kl))
+ W2xyz5(il, kl) = ccni2D(il, kl) * pst2Dn(il) * dsigm1(kl) &
+ + gravit * xtmn * (ccni2D(il, kl - 1) * &
+ vi(il, kl - 1) * rolv2D(il, kl - 1) &
+ - ccni2D(il, kl) * vi(il, kl) * rolv2D(il, kl))
+ enddo
+ enddo
+
+ do il = 1, klon
+ W2xyz1(il, mzhyd) = qi2D(il, mzhyd) * &
+ pst2Dn(il) * dsigm1(mzhyd) &
+ - gravit * xtmn * qi2D(il, mzhyd) * &
+ vi(il, mzhyd) * rolv2D(il, mzhyd)
+ W2xyz5(il, mzhyd) = ccni2D(il, mzhyd) * &
+ pst2Dn(il) * dsigm1(mzhyd) &
+ - gravit * xtmn * ccni2D(il, mzhyd) * &
+ vi(il, mzhyd) * rolv2D(il, mzhyd)
+ enddo
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qi2D(il, kl) = max(0., W2xyz1(il, kl) / &
+ (pst2Dn(il) * dsigm1(kl)))
+ ccni2D(il, kl) = max(0., W2xyz5(il, kl) / &
+ (pst2Dn(il) * dsigm1(kl)))
+ enddo
+ enddo
+
+ enddo
+ endif
+
+ ! Fractional Cloudiness ! Guess may be computed (Ek&Mahrt91 fracSC=.T.)
+ ! ====================== ! Final value computed below
+
+ ! #if(sc)
+ ! if (fracld.and..not.fracSC) then
+ ! #endif
+ if(itPhys == ntHyd2) then
+ if(fracld) then
+ if(fraCEP) then
+ ! ECMWF Large Scale Cloudiness
+ ! ----------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ cfra2D(il, kl) = (qi2D(il, kl) + qw2D(il, kl) &
+ + qs2D(il, kl) * 0.33 &
+ * (1. - min(1., exp((tair2D(il, kl) - 258.15) * &
+ 0.1)))) / (0.02 * qvsw2D(il, kl))
+ cfra2D(il, kl) = min(1.000, cfra2D(il, kl))
+ cfra2D(il, kl) = max(0.001, cfra2D(il, kl)) &
+ * max(0., sign(1., qi2D(il, kl) + qw2D(il, kl) &
+ + qs2D(il, kl) - 3.E-9))
+ enddo
+ enddo
+ else
+ ! XU and Randall 1996, JAS 21, p.3099 (4)
+ ! ----------------------------
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qvs_wi = qvsw2D(il, kl)
+#if(wi)
+ qvs_wi = max(eps9, ((qi2D(il, kl) + qs2D(il, kl)) * qvsi2D(il, kl) &
+ + qw2D(il, kl) * qvsw2D(il, kl)) / &
+ max(eps9, qi2D(il, kl) + qs2D(il, kl) + qw2D(il, kl)))
+#endif
+ relhum = min(relCri, max(qv2D(il, kl), qv_MIN) &
+ / qvs_wi)
+ argexp = ((relCri - relhum) * qvs_wi)**0.49
+ argexp = min(100. * (qi2D(il, kl) + qw2D(il, kl) &
+ + qs2D(il, kl) * 0.33 &
+ * (1. - min(1., exp((tair2D(il, kl) - 258.15) * &
+ 0.1)))) / &
+ max(eps9, argexp), argmax)
+
+ cfra2D(il, kl) = (relhum**0.25) * (1. - exp(-argexp))
+ enddo
+ enddo
+ endif
+ else
+ ! #if(sc)
+ ! else if (.not.fracld) then
+ ! #endif
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qcloud = qi2D(il, kl) + qw2D(il, kl)
+ if(qcloud > eps9) then
+
+ ! cfra2D(il,kl) = 1.0 if qcloud > eps9
+ ! cfra2D(il,kl) = 0.0 otherwise
+ signQW = sign(unun, qcloud - eps9)
+ cfra2D(il, kl) = max(zero, signQW)
+
+ endif
+ enddo
+ enddo
+ endif
+ endif
+#if(EW)
+ ! Vertically Integrated Energy and Water Content
+ ! ==============================================
+ do il = 1, klon
+ ! Vertical Integrated Energy and Water Content
+ enr21D(il) = 0.d0
+ wat21D(il) = 0.d0
+
+ do kl = 1, klev
+ enr21D(il) = enr21D(il) &
+ + (tair2D(il, kl) &
+ - (qw2D(il, kl) + qr2D(il, kl)) * r_LvCp &
+ - (qi2D(il, kl) + qs2D(il, kl)) * r_LsCp) * dsigm1(kl)
+ wat21D(il) = wat21D(il) &
+ + (qv2D(il, kl) &
+ + qw2D(il, kl) + qr2D(il, kl) &
+ + qi2D(il, kl) + qs2D(il, kl)) * dsigm1(kl)
+ enddo
+
+ ! wat21D [m] contains implicit factor 10**3 [kPa-->Pa] /ro_Wat
+ enr21D(il) = enr21D(il) * pst2Dn(il) * grvinv
+ wat21D(il) = wat21D(il) * pst2Dn(il) * grvinv
+
+ enddo
+#endif
+#if(WH)
+ ! OUTPUT
+ ! ======
+ if(mod(minuGE, 6) == 0 .and. jsecGE == 0 .and. ilmm > 0) then
+ write(6, 1030) jhlr2D(ilmm), minuGE, jsecGE, itexpe, imm, jmm
+ 1030 format(//, i4, 'LT', i2, 'm', i2, 's (iter.', i6, ') / Pt.(', 2i4, ')', &
+ /, ' ==========================================')
+ write(6, 1031)(kl, 0.1019d0 * gplv2D(ilmm, kl), qv2D(ilmm, kl), &
+ (10.**3) * qiold(kl), (10.**3) * qi2D(ilmm, kl), &
+ (10.**3) * wihm1(kl), (10.**3) * wihm2(kl), (10.**3) * wicnd(kl), &
+ (10.**3) * widep(kl), (10.**3) * wisub(kl), (10.**3) * wimlt(kl), kl = mzhyd, klev)
+ 1031 format(/, &
+ ' | Water Vapor | Cloud Ice, Time n & n+1', &
+ ' Cloud Ice Nucleation Processes |', &
+ ' Bergeron Sublimation Melting ', &
+ /, ' k z[m] | qv [g/kg] | qi_n [g/kg] qi_n+[g/kg]', &
+ ' QiHm1[g/kg] QiHm2[g/kg] QiCnd[g/kg] |', &
+ ' QiDep[g/kg] QiSub[g/kg] QiMlt[q/kg]', &
+ /, '------------+--------------+-------------------------', &
+ '-------------------------------------+', &
+ '-------------------------------------', &
+ /, (i3, f8.1, ' | ', f12.6, ' | ', 2f12.6, 3d12.4, ' | ', 3d12.4))
+
+ write(6, 1032)(kl, 0.1019d0 * gplv2D(ilmm, kl), &
+ (10.**3) * W2xyz4(ilmm, kl), (10.**3) * qs2D(ilmm, kl), &
+ (10.**3) * wsaut(kl), (10.**3) * wsaci(kl), (10.**3) * wsacw(kl), &
+ (10.**3) * wiacr(kl), (10.**3) * wsacr(kl), (10.**3) * wssub(kl), vs(ilmm, kl), &
+ kl = mzhyd, klev)
+ 1032 format(/, &
+ ' | Snow Flakes, Time n&n+1 Autoconver. |', &
+ ' Accretion Processes ===> Snow Flakes |', &
+ ' Sublimation | Term.F.Vel', &
+ /, ' k z[m] | qs_n [g/kg] qs_n+[g/kg] Qsaut[g/kg] |', &
+ ' Qsaci[g/kg] Qsacw[g/kg] Qiacr[g/kg] Qsacr[g/kg] |', &
+ ' QsSub[g/kg] | vs [m/s]', &
+ /, '------------+--------------------------------------+', &
+ '--------------------------------------------------+', &
+ '--------------+-----------', &
+ /, (i3, f8.1, ' | ', 2f12.6, e12.4, ' | ', 4d12.4, ' | ', e12.4, &
+ ' | ', f10.6))
+ write(6, 1033)(kl, 0.1019d0 * gplv2D(ilmm, kl), tair2D(ilmm, kl), &
+ (10.**3) * qwold(kl), (10.**3) * qw2D(ilmm, kl), &
+ (10.**3) * wwevp(kl), 1.d2 * cfra2D(ilmm, kl), kl = mzhyd, klev)
+ 1033 format(/, &
+ /, ' | Temperat.| Cloud Water, Time n&n+1', &
+ ' Condens/Evp | Cloud ', &
+ /, ' k z[m] | T [K] | qw_n [g/kg] qw_n+[g/kg]', &
+ ' QwEvp[g/kg] | Fract.', &
+ /, '------------+----------+-------------------------', &
+ '-------------+-------', &
+ /, (i3, f8.1, ' | ', f8.3, ' | ', 2f12.6, e12.4, ' | ', f5.1))
+
+ write(6, 1034)(kl, 0.1019d0 * gplv2D(ilmm, kl), &
+ (10.**3) * W2xyz3(ilmm, kl), (10.**3) * qr2D(ilmm, kl), &
+ (10.**3) * wraut(kl), (10.**3) * wracw(kl), (10.**3) * wraci(kl), &
+ (10.**3) * wracs(kl), (10.**3) * wrevp(kl), (10.**3) * wsfre(kl), vr(ilmm, kl), &
+ kl = mzhyd, klev)
+ 1034 format(/, &
+ /, ' | Rain Drops, Time n&n+1 Autoconver. |', &
+ ' Accretion Processes ===> Rain Drops |', &
+ ' Evaporation Freezing | Term.F.Vel', &
+ /, ' k z[m] | qr_n [g/kg] qr_n+[g/kg] Qraut[g/kg] |', &
+ ' Qracw[g/kg] Qraci[g/kg] Qracs[g/kg] |', &
+ ' QrEvp[g/kg] QsFre[g/kg] | vr [m/s]', &
+ /, '------------+--------------------------------------+', &
+ '--------------------------------------+', &
+ '--------------------------+-----------', &
+ /, (i3, f8.1, ' | ', 2f12.6, e12.4, ' | ', 3d12.4, ' | ', 2d12.4, &
+ ' | ', f10.6))
+
+ do kl = mzhyd, klev
+ wihm1(kl) = 0.d0
+ wihm2(kl) = 0.d0
+ wicnd(kl) = 0.d0
+ widep(kl) = 0.d0
+ wisub(kl) = 0.d0
+ wimlt(kl) = 0.d0
+ wwevp(kl) = 0.d0
+ wraut(kl) = 0.d0
+ wsaut(kl) = 0.d0
+ wracw(kl) = 0.d0
+ wsacw(kl) = 0.d0
+ wsaci(kl) = 0.d0
+ wraci(kl) = 0.d0
+ wiacr(kl) = 0.d0
+ wsacr(kl) = 0.d0
+ wracs(kl) = 0.d0
+ wrevp(kl) = 0.d0
+ wssub(kl) = 0.d0
+ wsmlt(kl) = 0.d0
+ wsfre(kl) = 0.d0
+ enddo
+ endif
+#endif
+
+#if(EW)
+ ! Vertical Integrated Energy and Water Content: OUTPUT
+ ! ====================================================
+ if(ilmez > 0) then
+ waterb = wat21D(ilmez) - wat11D(ilmez) - watf1D(ilmez)
+ write(6, 606) itexpe, &
+ enr01D(ilmez), (10.**3) * wat01D(ilmez), &
+ mphy2D(ilmez), &
+ enr11D(ilmez), (10.**3) * wat11D(ilmez), &
+ enr21D(ilmez), (10.**3) * wat21D(ilmez), &
+ (10.**3) * watf1D(ilmez), &
+ (10.**3) * waterb
+ 606 format(i9, ' Before mPhy: E0 =', f12.6, ' W0 = ', &
+ f9.6, 3x, a20, 3x, &
+ 9x, ' Before Prec: E1 =', f12.6, ' W1 = ', f9.6, &
+ 9x, ' After Prec: E2 =', f12.6, ' W2 = ', f9.6, &
+ ' W Flux =', f9.6, &
+ ' Div(W) =', e9.3)
+ endif
+#endif
+ if(jmmMAR == 0 .and. jssMAR == 0) then
+ IO_loc = IO_gen + 2
+ do io = io1, io5
+ if(io > 0) then
+ il = ioutIO(io)
+ if((itexpe > 0 .and. jmmMAR == 0 .and. jssMAR == 0 .and. &
+ ((IO_loc >= 4 .and. jhurGE == 0) .or. &
+ (IO_loc >= 5 .and. mod(jhurGE, 3) == 0) .or. &
+ (IO_loc >= 6))) .or. IO_loc >= 7) then
+ ! ***********
+ !cCA call TIMcor(i, j)
+ ! ***********
+ !cCA write(4, 1037) jdplus, mmplus, jhlr2D(il), minuGE, &
+ !cCA igrdIO(io), jgrdIO(io)
+ !cCA1037 format(' Ice-Crystal mPhy ', &
+ !cCA i2, '/', i2, 1x, i2, 'h', i2, 'LT', &
+ !cCA ' -- Grid Point (', i5, ',', i5, ')' // &
+ !cCA ' =================================' // &
+ !cCA '=========================' // &
+ !cCA ' | z [m] | T [K] | qi[g/kg] |' // &
+ !cCA ' Ni [m-3] | Ni0[m-3] | vi [m/s] | qs[g/kg] |' // &
+ !cCA '-----+---------+--------+----------+' // &
+ !cCA '----------+----------+----------+----------+')
+ do kl = mzhyd, klev
+ write(4, 1038) kl, gplv2D(il, kl) * grvinv, tair2D(il, kl), &
+ qi2D(il, kl) * (10.**3), &
+ ccni2D(il, kl), W2xyz2(il, kl), vi(il, kl), &
+ qs2D(il, kl) * (10.**3)
+ enddo
+ 1038 format((i4, ' |', f8.1, ' |', f7.2, ' |', f9.6, ' |', &
+ 2(d9.3, ' |'), 2(f9.6, ' |')))
+ endif
+ endif
+ enddo
+ IO_loc = IO_gen
+ endif
+
+#if(WH)
+ ilmm = ilmmi
+#endif
+ ! Latent Heat Release
+ ! ===================
+ do kl = mzhyd, klev
+ do il = 1, klon
+ pkt0 = pkta2D(il, kl)
+ pkta2D(il, kl) = tair2D(il, kl) / pk2D(il, kl)
+ hlat2D(il, kl) = tair2D(il, kl) * (1.d0 - pkt0 / pkta2D(il, kl)) &
+ / xt
+ enddo
+ enddo
+
+ ! Limits on Microphysical Variables
+ ! =================================
+ if(itPhys == ntHyd2) then
+ do kl = 1, max(1, mzhyd - 1)
+ do il = 1, klon
+ qr2D(il, mzhyd) = qr2D(il, mzhyd) + qr2D(il, kl) + qw2D(il, kl)
+#if(AC)
+ qs2D(il, mzhyd) = qs2D(il, mzhyd) + qs2D(il, kl) + qi2D(il, kl)
+#else
+ ! cXF BUGBUG 19/08/2022
+ qs2D(il, mzhyd) = qs2D(il, mzhyd) + qs2D(il, kl) + qi2D(il, kl) + &
+ (qv2D(il, kl) - min(qv2D(il, kl), qvsi2D(il, kl)))
+#endif
+ ccni2D(il, mzhyd) = ccni2D(il, mzhyd) + ccni2D(il, kl)
+ enddo
+ enddo
+
+ do kl = 1, max(1, mzhyd - 1)
+ do il = 1, klon
+ qv2D(il, kl) = max(qv2D(il, kl), qv_MIN)
+ qv2D(il, kl) = min(qv2D(il, kl), qvsi2D(il, kl)) ! mass loss
+ qw2D(il, kl) = zero
+ qi2D(il, kl) = zero
+ ccni2D(il, kl) = zero
+ qr2D(il, kl) = zero
+ qs2D(il, kl) = zero
+ snf2D(il, kl) = zero
+ sbl2D(il, kl) = zero
+ dep2D(il, kl) = zero
+ rnf2D(il, kl) = zero
+ evp2D(il, kl) = zero
+ smt2D(il, kl) = zero
+ qssbl2D(il, kl) = zero
+ enddo
+ enddo
+
+ do kl = mzhyd, klev
+ do il = 1, klon
+ qw2D(il, kl) = max(zero, qw2D(il, kl))
+ qi2D(il, kl) = max(zero, qi2D(il, kl))
+ ccni2D(il, kl) = max(zero, ccni2D(il, kl))
+ qr2D(il, kl) = max(zero, qr2D(il, kl))
+ qs2D(il, kl) = max(zero, qs2D(il, kl))
+ snf2D(il, kl) = max(zero, snf2D(il, kl))
+ sbl2D(il, kl) = max(zero, sbl2D(il, kl))
+ dep2D(il, kl) = max(zero, dep2D(il, kl))
+ rnf2D(il, kl) = max(zero, rnf2D(il, kl))
+ evp2D(il, kl) = max(zero, evp2D(il, kl))
+ smt2D(il, kl) = max(zero, smt2D(il, kl))
+ qssbl2D(il, kl) = max(zero, qssbl2D(il, kl))
+ enddo
+ enddo
+
+ do kl = 1, klev
+ do il = 1, klon
+ W2xyz1(il, kl) = 0.d0
+ W2xyz2(il, kl) = 0.d0
+ W2xyz3(il, kl) = 0.d0
+ W2xyz4(il, kl) = 0.d0
+ W2xyz5(il, kl) = 0.d0
+ W2xyz6(il, kl) = 0.d0
+ W2xyz7(il, kl) = 0.d0
+ W2xyz8(il, kl) = 0.d0
+ enddo
+ enddo
+ endif
+ return
+endsubroutine HYDmic
diff --git a/MAR/code_mar/inigen.f90 b/MAR/code_mar/inigen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dd2e32ab48dd42adf730f20f918623f4d2431723
--- /dev/null
+++ b/MAR/code_mar/inigen.f90
@@ -0,0 +1,2038 @@
+#include "MAR_pp.def"
+subroutine inigen
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT 5-10-2020 MAR |
+ ! | subroutine inigen set up MAR Initialization Procedure |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+#if(AO)
+ use mod_oasis
+ ! mar_module : TANGO modules
+ use mar_module
+#endif
+
+ ! +--Global Variables
+ ! + ================
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use marsnd
+ use mar_dy
+ use mar_lb
+ use mar_ub
+ use marsib
+ use mar_te
+ use mar_tu
+ use mar_fi
+ use mar_ra
+ use mar_hy
+ use mar_ca
+ use mar_pb
+ use mar_io
+ use marssn
+ use mar_sl
+#if(NH)
+ use mar_nh
+#endif
+#if(Di)
+ ! include 'MAR_DI.inc' #cCA
+#endif
+#if(TC)
+ use mar_tc
+#endif
+#if(AO)
+ use mar_ao
+ use mar_tv
+#endif
+#if(PO)
+ use mar_po
+#endif
+ use mar_sv
+#if(BS)
+ use mar_bs
+#endif
+#if(OL)
+ use mar_ol
+#endif
+#if(iso)
+ use mariso, only: iso_init_type, qvDY_iso, qvapSL_iso, &
+ dqv_CA_iso, dqw_CA_iso, dqi_CA_iso, &
+ drr_CA_iso, dss_CA_iso, dsn_CA_iso, &
+ rainCA_iso, snowCA_iso, &
+ qiHY_iso, qsHY_iso, qwHY_iso, &
+ qrHY_iso, rainHY_iso, rai0HY_iso, &
+ snowHY_iso, sno0HY_iso, sfa0HY_iso, crysHY_iso, &
+ SLuqs_iso, SLuqsl_iso
+#endif
+
+ implicit none
+
+#if(AO)
+ character * 100 filein
+ character * 3 mxc, myc
+ logical file_exists
+#endif
+
+ ! +--Local Variables and DATA
+ ! + ========================
+ integer i, j, k, m
+ external zext
+ integer zext
+ logical zoro
+ logical verti0
+ integer itever, itexpe2
+#if(NH)
+ integer iyrONH, mmaONH, jdaONH, jhuONH
+#endif
+ integer iyrCVA, mmaCVA, jdaCVA, jhuCVA
+ integer iyrHYD, mmaHYD, jdaHYD, jhuHYD
+#if(TC)
+ integer iyrTCA, mmaTCA, jdaTCA, jhuTCA
+#endif
+ integer iyrTUR, mmaTUR, jdaTUR, jhuTUR
+ integer iyrSOL, mmaSOL, jdaSOL, jhuSOL
+#if(PO)
+ integer iyrPOL, mmaPOL, jdaPOL, jhuPOL
+#endif
+ integer imezdy, jmezdy, mzabs1, itizon
+ integer lo_CAU, ipri, iv_ini, n, isl
+
+ ! +--Modified Time Step
+ ! + ~~~~~~~~~~~~~~~~~~
+ integer YYtmp, MMtmp, DDtmp
+ real dtdom, zmin_0, aavu_0, bbvu_0, ccvu_0, ps_sig
+#if(HF)
+ real hham, nham, hhac, thac
+#endif
+ real aladyn, alodyn, gradTz, rhcrit, tstart
+ real sh2(mx, my), sh3(mx, my, mw - 1)
+ character * 3 swich(0:1)
+ data swich/'OFF', 'ON '/
+ data ps_sig/100./
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ INITIALISATION of the DOMAIN characterISTICS +++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ open(unit=1, status='old', file='MARdom.dat')
+ rewind 1
+ read(1, 141) explIO
+141 format(a3)
+ read(1, 145) GElat0, GElon0, GEddxx
+ read(1, 1425) mma0GE, jda0GE, jhu0GE, itizon, iyr0GE
+1425 format(4i4, i4)
+ read(1, 1426) imez, jmez, maptyp, GEtrue
+1426 format(3i4, 28x, e13.6)
+ read(1, 1427) igrdIO
+1427 format(5i4)
+ read(1, 1427) jgrdIO
+ read(1, 1427) IO_gen
+ IO_loc = IO_gen
+ read(1, 1427) mxw1IO, mxw2IO, ixw_IO
+ read(1, 1427) myw1IO, myw2IO, iyw_IO
+ read(1, 1427) mzw1IO, mzw2IO, izw_IO
+ ! kkatIO, kmidIO : For output on NetCDF Files:
+ ! Assumed Levels of Bound.Layer / Mid Troposph.
+ read(1, 1427) kkatIO, kmidIO
+ read(1, 145) dx, dy, dtdom
+145 format(4d13.6)
+ read(1, 1450) verti0
+1450 format(l3)
+ ! ptopDY: model top pressure
+ read(1, 145) ptopDY
+ read(1, 145) zmin_0, aavu_0, bbvu_0, ccvu_0
+ z__SBL = zmin_0
+ read(1, 145) FIslot, FIslou, FIslop, FIkhmn
+ read(1, 145) TUkhff, TUkhmx
+ TUkhmx = TUkhmx * dtdom / dt
+ read(1, 145) tequil, dtquil
+ read(1, 145) zs_SL, zn_SL, zl_SL, cs2SL
+ read(1, 145) sst_SL
+ read(1, 145) dtagSL
+ read(1, 145) w20SL, wg0SL, wk0SL, wx0SL
+ read(1, 1430)
+1430 format(1x)
+ read(1, 143) isolSL
+143 format((10i13))
+ read(1, 1430)
+ read(1, 1432) sh2
+ if(itexpe <= 1) then
+ sh = sh2
+ endif
+1432 format((10d13.6))
+ read(1, 1430)
+ read(1, 1432) SL_z0
+ read(1, 1430)
+ read(1, 1432) SL_r0
+ read(1, 1430)
+ read(1, 1432) ch0SL
+ read(1, 1430)
+ read(1, 1432) rsurSL
+ read(1, 1430)
+
+ ! +--Underlaying Surface Albedo (to which Surface alb0SL is set,
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~ unless NOT 1st Run, itexpe /= 0)
+ read(1, 1432) albsSL
+ alb0SL = albsSL
+ read(1, 1430)
+ read(1, 1432) eps0SL
+ read(1, 1430)
+ read(1, 1432) d1_SL
+#if(po)
+ read(1, 1430)
+ read(1, 1432) uocnPO
+ read(1, 1430)
+ read(1, 1432) vocnPO
+ read(1, 1430)
+ read(1, 1432) aPOlyn
+#endif
+ if(geoNST) then
+ read(1, 1430)
+ read(1, 1432)((GElonh(i, j), i=1, mx), j=1, my)
+ read(1, 1430)
+ read(1, 1432)((GElatr(i, j), i=1, mx), j=1, my)
+ read(1, 1430)
+ read(1, 1432) sigma
+
+ ! degrees --> radians
+ GElatr = GElatr * degrad
+ ! degrees --> hours
+ GElonh = GElonh / 15.
+
+ do k = 1, mz
+ zsigma(k) = -(sst_SL / 0.0065) * ((1.e0 + (sigma(k) - 1.) &
+ * (1.e2 / ps_sig))**(RDryAi * 0.0065 / gravit) - 1.)
+ enddo
+
+ if(IO_gen >= 2) then
+ write(21, 130)(sigma(k), k=1, mz)
+130 format(/, ' Sigma Levels :', /,(1x, 15f8.4))
+ write(21, 131)(zsigma(k), k=1, mz)
+131 format(/, ' Altitude Levels :', /,(1x, 15f8.1))
+ endif
+ endif
+
+#if(OR)
+ ! +--Orography Roughness
+ ! + ~~~~~~~~~~~~~~~~~~~
+ do k = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ SLzoro(i, j, k) = SL_z0(i, j, k)
+ enddo
+ enddo
+ enddo
+ zoro = .true.
+ zoro = .false.
+ if(zoro) STOP '@#! Uses Andreas parameterization of z0_h with z0_oro'
+#endif
+ close(unit=1)
+
+ ! + *** *CL* Read subgrid topography ***
+ if(mw == 5) then
+ open(unit=555, status='old', file='MARdom2.dat')
+ print *, '***************************'
+ print *, '* Read of MARdom2.dat *'
+ print *, '***************************'
+ read(555, '(f12.6)') sh3
+ if(itexpe <= 1) then
+ do i = 1, mx
+ do j = 1, my
+ do k = 1, nsx - 1
+ sh_int(i, j, k) = sh3(i, j, k)
+ enddo
+ sh_int(i, j, nsx) = sh(i, j)
+ enddo
+ enddo
+ endif
+ close(unit=555)
+ endif
+
+#if(AO)
+ ! + *** AO_CK ***
+ ! Read Weight file (combine SSC from reanalysis and ocean model) ***
+ print *, "check if coupling AO:", coupling_ao
+ if(coupling_ao) then
+ write(mxc, '(i3)') mx
+ if(mx < 100) write(mxc, '(i2)') mx
+ write(myc, '(i3)') my
+ if(my < 100) write(myc, '(i2)') my
+ filein = 'TROUPLE-'//trim(mxc)//'x'//trim(myc)//'.cdf'
+ inquire(file=trim(filein), exist=file_exists)
+ if(file_exists) then
+ call CF_READ2D(trim(filein), 'WEIGHT', 1, mx, my, 1, weightao)
+ print *, 'Read ', trim(filein)
+ else
+ print *, 'Define TROUPLE file before coupling!'
+ stop
+ endif
+ do i = 1, mx
+ do j = 1, my
+ ! NO NEMO field in the first 3 pixels from the relaxation zone
+ ! They MUST also be considered as LAND for OASIS
+ if(i <= 3) weightao(i, j) = 1.
+ ! even if they are ocean
+ if(j <= 3) weightao(i, j) = 1.
+ if(i >= mx - 2) weightao(i, j) = 1.
+ if(j >= my - 2) weightao(i, j) = 1.
+ enddo
+ enddo
+ ! USING variable from coupling
+ ! 1 = rean everywhere 0=NEMO everywhere
+ ! = weightao NEMO/REANALYSIS
+ ! weightao_sst : sst
+ weightao_sst = weightao
+ ! weightao_sic : SIC
+ weightao_sic = weightao
+ ! weightao_st : Sea ice/ Snow on ice surface temp
+ weightao_st = weightao
+ ! weightao_al : Sea/Snow on ice Albedo
+ weightao_al = weightao
+ ! weightao_sit : Sea ice thickness
+ weightao_sit = weightao
+ ! weightao_snt : Snow on ice thickness
+ weightao_snt = weightao
+ print *, "If doubt(s) on coupling, check weightao definition"
+ endif
+#endif
+
+ ! +--SVAT IO
+ ! + -------
+ if(vegmod .and. .not. reaVAR) then
+ ! + ******
+ call svasav('read')
+ ! + ******
+ endif
+
+ ! +--Time Discretisation
+ ! + ===================
+
+ ! +--Slow Dynamics
+ ! + -------------
+ idt = dt
+ jdt = (dt - idt) * 100.
+
+ ! +--Fast Dynamics
+ ! + -------------
+ dtfast = dt / (ntFast + 1)
+
+ ! +--Subgrids
+ ! + --------
+ if(dtDiff < dt) then
+ if(dtDiff > 0.) then
+ ! ntDiff : Number of Subgrid Scale Steps for 1 Dynamical Step
+ ntDiff = dt / dtDiff
+ ! dtDiff : Calibrated Subgrid Scale Time Step
+ dtDiff = dt / ntDiff
+ jtDiff = 1
+ else
+ ntDiff = 1
+ jtDiff = nboucl * nprint + 1
+ endif
+ else
+ ! jtDiff : Number of Dynamical Steps for 1 Subgrid Scale Step
+ jtDiff = dtDiff / dt
+ jtDiff = max(jtDiff, 1)
+ ! dtDiff : Calibrated Subgrid Scale Time Step
+ dtDiff = dt * jtDiff
+ ntDiff = 1
+ endif
+ if(dtDiff > 0.) then
+ !XF
+ ntDiff = 1
+ dtDiff = dt
+ jtDiff = 1
+ !XF
+ endif
+
+ ! +--Surface Physics
+ ! + -----------------
+ if(dtPhys < dt) then
+ ! ntPhys : Number of Surface Phys. Steps for 1 Dynamical Step
+ ntPhys = dt / dtPhys
+ ! dtPhys : Calibrated Surface Phys. Time Step
+ dtPhys = dt / ntPhys
+ jtPhys = 1
+ else
+ ! jtPhys : Number of Dynamical Steps for 1 Surface Phys. Step
+ jtPhys = dtPhys / dt
+ jtPhys = max(jtPhys, 1)
+ ! dtPhys : Calibrated Surface Physics Time Step
+ dtPhys = dt * jtPhys
+ ntPhys = 1
+ endif
+
+ !XF
+ ntPhys = 1
+ dtPhys = dt
+ jtPhys = 1
+ !XF
+
+ ! +--Radiation Physics
+ ! + -----------------
+ if(dtRadi < dt) then
+ write(6, *) ' NO Split Time Differ. on dtRadi !!#�@|#@&##!! EMERGENCY EXIT '
+ STOP
+ ! ntRadi : Number of Surface Phys. Steps for 1 Dynamical Step
+ ntRadi = dt / dtRadi
+ ! dtRadi : Calibrated Surface Phys. Time Step
+ dtRadi = dt / ntRadi
+ jtRadi2 = 1
+ else
+ ! jtRadi : Number of Dynamical Steps for 1 Surface Phys. Step
+ jtRadi2 = dtRadi / dt
+ ! dtRadi : Calibrated Surface Physics Time Step
+ dtRadi = dt * jtRadi2
+ ntRadi = 1
+ endif
+
+ ! +--Other Constants
+ ! + ---------------
+
+ t2SLtn = 1.0 / dtPhys - 0.50 / cs2SL
+ t2SLtd = 1.0 / dtPhys + 0.50 / cs2SL
+ ! fracSL : Fractional Time (Blowing Snow Srf Flux Computation)
+ ! Factor 1.8d3 is the Turbulence Time Scale (1/2 h)
+ ! Factor 0.6d3 is used.
+ fracSL = dt / 0.6e3
+ fracSL = min(unun, fracSL)
+
+ ! +--Coriolis Parameter
+ ! + ==================
+ ! fcorDY : Coriolis Parameter (Indicative Value)
+ fcorDY(imez, jmez) = 2.0 * earthv * sin(GElat0 * degrad)
+
+ ! +--OUTPUT
+ ! + ======
+ if(IO_loc >= 1) then
+ write(21, 600) explIO, GElat0, GElon0, &
+ jda0GE, mma0GE, jhu0GE, itizon, &
+ minuGE, jsecGE, fcorDY(imez, jmez), cz0_GE
+600 format(/, ' SIMULATION ', a3, /, ' ++++++++++++++', //, &
+ ' Lat.', f5.1, 3x, 'Long.', f6.1, 4x, 'Date :', i3, '-', i2, &
+ ' / ', i2, ' h.UT +(', i3, ')LT', i3, ' min.', i3, ' sec.', &
+ //, ' f(Coriolis) = ', e12.5, &
+ /, ' cos(Z) min : ', e12.5)
+ write(21, *) ' CODE STATUS +++++++++++'
+#if(HF)
+ write(21, *) '#HF Initialisation of Huang and Lynch 1993 (HAMMING Filter)'
+#endif
+#if(NH)
+ write(21, *) '#NH DYNAMICS: Non-Hydrost. Code (adapted from Laprise, 1992)'
+#endif
+#if(ON)
+ write(21, *) '#ON DYNAMICS: Non-Hydrost. Corr. (Weisman &al.1997 MWR p.541)'
+#endif
+#if(DD)
+ write(21, *) '#DD DYNAMICS: Mass Divergence Damper (Skamarock &Klemp, 1992)'
+#endif
+ write(21, *) '#VN DYNAMICS: Variable Number of Leap-Frog Loops (Fast Waves)'
+#if(IL)
+ write(21, *) '#IL DYNAMICS: PGF: SBL Fraction with Air = Surface Temperat.'
+#endif
+#if(GE)
+ write(21, *) '#GE DYNAMICS: Geographic Coordinates may be red in MARdom.dat'
+#endif
+#if(CC)
+ write(21, *) '#CC DYNAMICS: Constant Coriolis Parameter = fcorDY(imez,jmez)'
+#endif
+#if(HE)
+ write(21, *) '#HE DYNAMICS: NORLAM Vertical Discretisation(29 Levels)'
+#endif
+#if(lm)
+ write(21, *) '#lm DYNAMICS: LMDZ Model Vertical Discretisation(11 Levels)'
+#endif
+#if(PA)
+ write(21, *) '#PA DYNAMICS: Parish Model Vertical Discretisation(10 Levels)'
+#endif
+#if(PV)
+ write(21, *) '#PV DYNAMICS: Large Scale Flow conserves Pot. Vort. (2D ONLY)'
+#endif
+#if(pv)
+ write(21, *) '#pv DYNAMICS: Large Scale Flow conserves Pot. Temp. (2D ONLY)'
+#endif
+#if(UW)
+ write(21, *) '#UW DYNAMICS: Advect. 3rd Accurate in Space Upstream Scheme '
+#endif
+#if(UP)
+ write(21, *) '#UP DYNAMICS: Vertical 1st Accurate in Space Upstream Scheme '
+#endif
+#if(ZU)
+ write(21, *) '#ZU DYNAMICS: Vertical Advection: Cubic Spline (4th accurate)'
+#endif
+#if(ZO)
+ write(21, *) '#ZO DYNAMICS: Vertical Advection: Cubic Spline (+Open SrfBC)'
+#endif
+#if(UR)
+ write(21, *) '#UR DYNAMICS: Vertical Advection/ Upper Radiating Bound.Cond.'
+#endif
+#if(EP)
+ write(21, *) '#EP DYNAMICS: Lateral Sponge included in Horizontal Filter'
+#endif
+#if(RB)
+ write(21, *) '#RB DYNAMICS: Lateral BC: Carpenter(1982) Sommerfeld Modified'
+#endif
+ write(21, *) '#DA DYNAMICS: Lateral BC: Davies (1976) BC on Wind // Lat.B. '
+#if(da)
+ write(21, *) '#da DYNAMICS: Lateral BC: Davies (1976) BC: K, nu computed. '
+#endif
+#if(FB)
+ write(21, *) '#FB DYNAMICS: Lateral BC: Fixed in Horizontal Cubic Spline '
+#endif
+#if(OB)
+ write(21, *) '#OB DYNAMICS: Lateral BC: Zero Gradient '
+#endif
+#if(OG)
+ write(21, *) '#OG DYNAMICS: Lateral BC: (Left) NO Nudging if relaxg=.false.'
+#endif
+#if(ob)
+ write(21, *) '#ob DYNAMICS: Lateral BC: Zero Gradient (Subroutine LBC000) '
+#endif
+ write(21, *) '#RF DYNAMICS: Top BC: Rayleight Friction in the Top Sponge '
+#if(Di)
+ write(21, *) '#Di DYNAMICS: Top BC: Dirichlet (fixed) '
+#endif
+#if(V)
+ write(21, *) '#V+ DYNAMICS: Top BC: Von Neuman (prescrib.non zero-gradient)'
+#endif
+#if(PS)
+ write(21, *) '#PS DYNAMICS: Domain Averaged Pressure Thickness maintained'
+#endif
+#if(DY)
+ write(21, *) '#DY DYNAMICS: OUTPUT: Components lowest Level Forces Balance'
+#endif
+#if(_PE)
+ write(21, *) '_PE DIFFUSION:(%Grad.) Slope USE+ _HH or (_HH #CR)'
+#endif
+#if(PE)
+ write(21, *) '#PE DIFFUSION:(%Deform.) Slope USE+ #DF or (#DF #DC #CR)'
+#endif
+#if(_HH)
+ write(21, *) '_HH DIFFUSION:(%Grad.) Vert.Cor. USE+ _PE '
+#endif
+#if(DF)
+ write(21, *) '#DF DIFFUSION:(%Deform.) Vert.Cor. USE+ #PE or (#PE #DC #CR)'
+#endif
+#if(DC)
+ write(21, *) '#DC DIFFUSION:(%Deform.) USE+ (#DF #PE #CR)'
+#endif
+#if(CR)
+ write(21, *) '#CR DIFFUSION: Cross Corr. USE+ (_PE _HH) or (#DF #PE #DC)'
+#endif
+#if(FE)
+ write(21, *) '#FE FILTERING: Digital Filtering of TKE '
+#endif
+#if(fe)
+ write(21, *) '#fe FILTERING: Digital Filtering of TKE is not vectorized '
+#endif
+#if(FO)
+ write(21, *) '#FO FILTERING: Digital Filtering of TKE (zero gradient at LB)'
+#endif
+#if(KS)
+ write(21, *) '#KS FILTERING: Upper Sponge is solved by horizontal filtering'
+#endif
+#if(BR)
+ write(21, *) '#BR TURBULENCE: 2.5 Level 2nd Order (Brasseur 1997)'
+#endif
+ write(21, *) '#CA CONVECTIVE Adjustment (general Set Up) '
+#if(cA)
+ write(21, *) '#cA CONVECTIVE Adjustment (no Double Counting Set Up) '
+#endif
+ write(21, *) '#ca CONVECTIVE Adjustment (no Vector Set Up)NV'
+#if(FC)
+ write(21, *) '#FC CONVECTIVE Adjustment (Fritsch & Chappell 1980 Set Up) '
+#endif
+#if(fc)
+ write(21, *) '#fc CONVECTIVE Adjustment (Fritsch & Chappell 1980 Set Up)NV'
+#endif
+#if(kf)
+ write(21, *) '#kf CONVECTIVE Adjustment (Kain & Fritsch 1990 Improvm.)'
+#endif
+#if(IT)
+ write(21, *) '#IT CONVECTIVE Adjustment (over 5km Adiabatics Starting Pts)'
+#endif
+#if(AN)
+ write(21, *) '#AN CONVECTIVE Adjustment (Subgrid Mountain Breeze included)'
+#endif
+#if(WD)
+ write(21, *) '#WD CONVECTIVE Adjustment (Water Detrainment included)'
+#endif
+#if(CG)
+ write(21, *) '#CG CONVECTIVE Adjustment (Cloud Glaciation included)'
+#endif
+#if(ND)
+ write(21, *) '#ND CONVECTIVE Adjustment (No Precip if LevFSink<LiftCond.L)'
+#endif
+#if(vT)
+ write(21, *) '#vT CONVECTIVE Adjustment (Virtual Temperature is computed)'
+#endif
+ write(21, *) '#PB CONVECTIVE Adjustment (Peter Bechtold 2000 Set Up) '
+ write(21, *) '#pb CONVECTIVE Adjustment (Peter Bechtold 2000 Set Up)NV'
+#if(KE)
+ write(21, *) '#KE CONVECTIVE Adjustment (Emanuel & Zivkovic 1999 Set Up) '
+#endif
+#if(LE)
+ write(21, *) '#LE TURBULENCE: K : Louis (1979) BLM 17'
+#endif
+#if(Kl)
+ write(21, *) '#Kl TURBULENCE: K-l: Therry & Lacarrere (1983) BLM 25'
+#endif
+#if(PD)
+ write(21, *) '#PD TURBULENCE: K-e: Original Duynkerke (1988) JAS 45'
+#endif
+ write(21, *) '#TA TURBULENCE: K-e: Dissipation + Advect.Horiz.TKE Transport'
+ write(21, *) '#TD TURBULENCE: K-e: Dissipation + Diffus.Horiz.TKE Transport'
+#if(AV)
+ write(21, *) '#AV TURBULENCE: K-e: Buoyancy includes Aerosol Loading '
+#endif
+#if(HR)
+ write(21, *) '#HR TURBULENCE: K-e: Huang & Raman (1991) BLM 55'
+#endif
+#if(KI)
+ write(21, *) '#KI TURBULENCE: K-e: Kitada (1987) BLM 41'
+#endif
+#if(BH)
+ write(21, *) '#BH TURBULENCE: K-e: Kitada (modified) USE with #KI'
+#endif
+#if(KC)
+ write(21, *) '#KC TURBULENCE: T.K.E.(mz1) := T.K.E.(mz) '
+#endif
+ write(21, *) '#KA TURBULENCE: T.K.E. & e(T.K.E.) Filter along the vertical '
+#if(AM)
+ write(21, *) '#AM TURBULENCE: u* Time Mean (BOX Moving Average) '
+#endif
+#if(AT)
+ write(21, *) '#AT TURBULENCE: u*T* Time Mean (BOX Moving Average) '
+#endif
+#if(AS)
+ write(21, *) '#AS TURBULENCE: u*s* Time Mean (BOX Moving Average) '
+#endif
+#if(VX)
+ write(21, *) '#VX TURBULENCE: u*q* limited to SBL Saturat. Specif. Humidity'
+#endif
+#if(De)
+ write(21, *) '#De TURBULENCE: Top BC: Dirichlet (fixed) (ect_TE and eps_TE)'
+#endif
+#if(WE)
+ write(21, *) '#WE TURBULENCE: T.K.E. OUTPUT on File MAR.TKE '
+#endif
+#if(AE)
+ write(21, *) '#AE TURBULENCE: Aerosols Erosion / Turbulent Diffusion Coeff.'
+#endif
+ write(21, *) '#SY TURBULENCE: Sea Spray Parameterization (Andreas, 199x) ON'
+#if(DU)
+ write(21, *) '#DU SBL: Univ.Funct.: Duynkerke(1991) '
+#endif
+#if(BU)
+ write(21, *) '#BU SBL: Univ.Funct.: Businger (1973) USE with _NO OR #NO'
+#endif
+#if(_NO)
+ write(21, *) '_NO SBL: Univ.Funct.: NO Noilhan (1987) USE with #BU OR #DR'
+#endif
+#if(NO)
+ write(21, *) '#NO SBL: Univ.Funct.: Noilhan (1987) USE with #BU '
+#endif
+#if(DR)
+ write(21, *) '#DR SBL: Univ.Funct.: Dyer (1974) USE with _NO '
+#endif
+#if(LP)
+ write(21, *) '#LP SBL: Blowing Snow Fric. Veloc. Thr. (Li and Pomeroy 1997)'
+#endif
+#if(DS)
+ write(21, *) '#DS SBL: Blowing Snow SBL Flux (analytical Form of dq/dz)'
+#endif
+ write(21, *) '#ZS SBL: Mom.: Roughn.Length= F(u*) Chamberlain (1983), Sea '
+#if(ZN)
+ write(21, *) '#ZN SBL: Mom.: Roughn.Length= F(u*) Shao & Lin (1999), Snow '
+#endif
+#if(ZA)
+ write(21, *) '#ZA SBL: Mom.: Roughn.Length= F(u*) Andreas &al.(2004), Snow '
+#endif
+#if(RN)
+ write(21, *) '#RN SBL: Heat: Roughn.Length= F(u*,z0) Andreas (1987) '
+#endif
+ write(21, *) '#ZM SBL: M/H Roughn.Length: Box Moving Average (in Time) '
+#if(OR)
+ write(21, *) '#OR SBL: Orography Roughness included from SL_z0 in MARdom '
+#endif
+#if(SB)
+ write(21, *) '#SB Surface Boundary: modified externally (from Campain Data)'
+#endif
+ write(21, *) '#TI Turbul. Heat Surface Flux: Implicit numerical Scheme '
+ write(21, *) '#QE Turbul. H2O Surface Flux: Explicit numerical Scheme '
+ write(21, *) '#FI Turbul. Mom. Surface Flux: Implicit numerical Scheme '
+#if(BI)
+ write(21, *) '#BI Blowing Snow Surface Flux: Implicit numerical Scheme '
+#endif
+#if(OL)
+ write(21, *) '#OL TEST: Linear Mountain Wave: Specific IO (2D ONLY)'
+#endif
+#if(OM)
+ write(21, *) '#OM TEST: (Non)Linear Mountain Wave: Specific INPUT (2D ONLY)'
+#endif
+#if(OS)
+ write(21, *) '#OS TEST: Linear Mountain Wave: Specific IO (2D ONLY)'
+#endif
+#if(K1)
+ write(21, *) '#K1 TEST: LBC: Katab. Atmos.Warming (1D ONLY)'
+#endif
+#if(EK)
+ write(21, *) '#EK TEST: EKMAN Spiral: Constant Vertical Turbul. Coefficient'
+#endif
+#if(CL)
+ write(21, *) '#CL TEST: Convective Mixed Layer Test (HS = 100 W/m2)'
+#endif
+#if(NL)
+ write(21, *) '#NL TEST: Nearly Neutral Layer Test (HS = 0 W/m2)'
+#endif
+#if(TC)
+ write(21, *) '#TC TraCer Advection-Diffusion Equation is turned ON'
+#endif
+#if(tc)
+ write(21, *) '#tc TraCer Filtering is not vectorized '
+#endif
+#if(TO)
+ write(21, *) '#TO TraCer Open Lateral Boundary Conditions on digit.Filter'
+#endif
+#if(TS)
+ write(21, *) '#TS TraCer Tracer Deposition diagnostic is turned ON'
+#endif
+#if(BD)
+ write(21, *) '#BD TraCer Aeolian Erosion Submodel is turned ON'
+#endif
+#if(DV)
+ write(21, *) '#DV TraCer Aeolian Erosion Submodel: Air Loading by Dust '
+#endif
+#if(CH)
+ write(21, *) '#CH Chemical Atmospheric Model may be turned ON'
+#endif
+#if(MV)
+ write(21, *) '#MV TraCer Total Mass Verification is turned ON'
+#endif
+ write(21, *) '#HY Explicit Cloud MICROPHYSICS may be turned ON'
+ write(21, *) '#hy Explicit Cloud MICROPHYSICS: NO Vectorisation Optmization'
+#if(HM)
+ write(21, *) '#HM Explicit Cloud MICROPHYSICS: Hallett-Mossop Ice Multipl. '
+#endif
+#if(hm)
+ write(21, *) '#hm Explicit Cloud MICROPHYSICS: Hallett-Mossop Ice Mult. NV'
+#endif
+#if(LI)
+ write(21, *) '#LI Explicit Cloud MICROPHYSICS: Lin et al. (1983) Autoconv. '
+#endif
+#if(BS)
+ write(21, *) '#BS Explicit Cloud MICROPHYSICS: Blow. *(Snow) Model '
+#endif
+ write(21, *) '#HV Explicit Cloud MICROPHYSICS: Air Loading by Hydrometeors '
+#if(BV)
+ write(21, *) '#BV Explicit Cloud MICROPHYSICS: SBL Loading by all Water Sp.'
+#endif
+#if(bv)
+ write(21, *) '#bv Explicit Cloud MICROPHYSICS: SBL Loading not vectorized '
+#endif
+#if(SS)
+ write(21, *) '#SS Explicit Cloud MICROPHYSICS: Blow. *(Snow) Linear Model '
+#endif
+#if(S0)
+ write(21, *) '#S0 Explicit Cloud MICROPHYSICS: Blow. *(Byrd) Linear Model '
+#endif
+#if(EM)
+ write(21, *) '#EM Explicit Cloud MICROPHYSICS: de Montmollin Parameterizat.'
+#endif
+#if(BW)
+ write(21, *) '#BW Explicit Cloud MICROPHYSICS: Blowing Snow Statistics '
+#endif
+#if(b2)
+ write(21, *) '#b2 Explicit Cloud MICROPHYSICS: Blowing Snow Statistics (II)'
+#endif
+#if(EV)
+ write(21, *) '#EV Explicit Cloud MICROPHYSICS: Snow Erosion Statistics '
+#endif
+ write(21, *) '#HW Explicit Cloud MICROPHYSICS: OUTPUT of qr,qs, qw,qi on NC'
+#if(EW)
+ write(21, *) '#EW Explicit Cloud MICROPHYSICS: OUTPUT (Ener./Mass) (Unit 6)'
+#endif
+#if(WH)
+ write(21, *) '#WH Explicit Cloud MICROPHYSICS: OUTPUT (Unit 6)'
+#endif
+#if(WQ)
+ write(21, *) '#WQ Explicit Cloud MICROPHYSICS: OUTPUT (Full Verif) (Unit 6)'
+#endif
+#if(WB)
+ write(21, *) '#WB Explicit Cloud MICROPHYSICS: Water Conservation Controled'
+#endif
+#if(WW)
+ write(21, *) '#WW Explicit Cloud MICROPHYSICS: Water Conservation Summary '
+#endif
+#if(ww)
+ write(21, *) '#WW Explicit Cloud MICROPHYSICS: Water Conservation Summary +'
+#endif
+#if(WF)
+ write(21, *) '#WF Explicit Cloud MICROPHYSICS: Water Conservation is Forced'
+#endif
+#if(HO)
+ write(21, *) '#HO Explicit Cloud MICROPHYSICS: Zero-Gradient Lat.Bound.Cond'
+#endif
+#if(MR)
+ write(21, *) '#MR PHYSICS: MARrad: Solar/Infrared (Laurent LI set up) '
+#endif
+#if(AZ)
+ write(21, *) '#AZ PHYSICS: Solar : Direct Radiation: Surface Slope Impact'
+#endif
+#if(MM)
+ write(21, *) '#MM PHYSICS: Solar : Direct Radiation: Mountains Mask ON'
+#endif
+#if(TR)
+ write(21, *) '#TR PHYSICS: Solarn: Clear Sky, without Underlying Reflection'
+#endif
+ write(21, *) '#EE PHYSICS: radCEP: ECMWF routine (cfr. JJ Morcrette) '
+#if(LL)
+ write(21, *) '#LL PHYSICS: radLMD: radlwsw routine (Laurent LI set up) '
+#endif
+#if(ll)
+ write(21, *) '#ll PHYSICS: radLMD: radlwsw routine (Laurent LI set up)NV'
+#endif
+#if(AR)
+ write(21, *) '#AR PHYSICS: radLMD: radlwsw routine Interactive Terr.Aerosol'
+#endif
+#if(WL)
+ write(21, *) '#WL PHYSICS: radLMD: radlwsw routine IO (Laurent LI set up) '
+#endif
+#if(SA)
+ write(21, *) '#SA PHYSICS: MAR Code behaves as a Stand Alone Surface Model'
+#endif
+#if(FR)
+ write(21, *) '#FR Surface Model: Force Restore (Deardorff) at least is ON'
+#endif
+#if(WG)
+ write(21, *) '#WG Soil Humidity: Force Restore (Deardorff) may be turned ON'
+#endif
+#if(AO)
+ write(21, *) '#AO COUPLING with NEMO Ocean-Sea-Ice Model using OASIS '
+#endif
+#if(PO)
+ write(21, *) '#PO POLYNYA Model may be turned ON'
+#endif
+#if(FD)
+ write(21, *) '#FD POLYNYA Model: Sea-Ice Velocity is Free Drift '
+#endif
+#if(HA)
+ write(21, *) '#HA POLYNYA Model: POLYNYA Surface Energy Balance: 2000 W/m2'
+#endif
+#if(HI)
+ write(21, *) '#HI POLYNYA Model: Hibler (1979) Parameteriz. of Ice Strength'
+#endif
+#if(CN)
+ write(21, *) '#CN POLYNYA Model: Prescription of a Local Avective Time Step'
+#endif
+#if(ST)
+ write(21, *) '#ST EVOLUTIVE SST (Sea Surface Temperature/Swab Ocean) '
+#endif
+#if(RE)
+ write(21, *) '#RE PRESCRIB. SST (Sea Surface Temperature/Reynolds DATA Set)'
+#endif
+ write(21, *) '#SN SNOW Model may be turned ON'
+#if(AB)
+ write(21, *) '#AB SNOW Model: Interactive Albedo f(Grain) (Brun et al.1991)'
+#endif
+#if(AG)
+ write(21, *) '#AG SNOW Model: Snow Aging Col de Porte (Brun et al.1991)'
+#endif
+ write(21, *) '#CZ SNOW Model: Zenithal Angle Correction (Segal et al.1991)'
+#if(DG)
+ write(21, *) '#DG SNOW Model: Snow Settling when Melting | Minimum Density '
+#endif
+#if(Se)
+ write(21, *) '#Se SNOW Model: Energy Conserv. Verific.: Summary, Output '
+#endif
+#if(SE)
+ write(21, *) '#SE SNOW Model: Energy Conserv. Verific.: Summary, Output+ '
+#endif
+#if(SF)
+ write(21, *) '#SF SNOW Model: Energy Conserv. Verific.: Forcing, Conduction'
+#endif
+#if(SW)
+ write(21, *) '#SW SNOW Model: Water Conserv. Verific.: Melting, Freezing '
+#endif
+#if(HS)
+ write(21, *) '#HS SNOW Model: Hardened SNOW Pack Initialization '
+#endif
+#if(MA)
+ write(21, *) '#MA SNOW Model: Increased polar B* Mobility (Mann et al.2000)'
+#endif
+#if(NP)
+ write(21, *) '#NP SNOW Model: Fallen Snow Density = f(V) (Kotlyakov, 1961)'
+#endif
+ write(21, *) '#SD SNOW Model: Antarct.,Fallen Snow Density (NP must be OFF)'
+#if(RU)
+ write(21, *) '#RU SNOW Model: Slush: Internal Run OFF of Water Excess '
+#endif
+#if(GK)
+ write(21, *) '#GK SNOW Model: Interactive Albedo (Greuell &Konzelmann 1994)'
+#endif
+#if(SL)
+ write(21, *) '#SL SNOW Model: Interactive Albedo (Zuo &Oerlemans 1995)'
+#endif
+#if(SM)
+ write(21, *) '#SM SNOW Model: Melting/Freezing Diagnostics '
+#endif
+#if(SZ)
+ write(21, *) '#SZ SNOW Model: Z0 Dependance on varying Sastrugi Height '
+#endif
+#if(TZ)
+ write(21, *) '#TZ SNOW Model: Z0 (Momentum) (typical value in polar models)'
+#endif
+#if(CP)
+ write(21, *) '#CP SNOW Model: For Validation on Col de Porte Data '
+#endif
+#if(GL)
+ write(21, *) '#GL SNOW Model: ETH-Camp & Greenland 3D simulations '
+#endif
+#if(PP)
+ write(21, *) '#PP PROJECTION: Polar Stereographic Projection '
+#endif
+ write(21, *) '#TV Soil /Vegetation Variables are used '
+#if(GP)
+ write(21, *) '#GP Soil /Vegetation Model: LAI, GLF Variations NOT prescrib.'
+#endif
+#if(LN)
+ write(21, *) '#LN Soil /Vegetation Model: LAI(x,y,t) prescribed(MARglf.DAT)'
+#endif
+#if(SV)
+ write(21, *) '#SV Soil /Vegetation Model (Koen De Ridder) may be turned ON'
+#endif
+#if(SH)
+ write(21, *) '#SH Soil /Vegetation Model: Hapex-Sahel Vegetation DATA'
+#endif
+#if(V1)
+ write(21, *) '#V1 Soil /Vegetation Model: (KD) Vegetat. IGBP Classification'
+#endif
+#if(V2)
+ write(21, *) '#V2 Soil /Vegetation Model: (KD) Vegetat. MAR Classification'
+#endif
+#if(GA)
+ write(21, *) '#GA SISVAT: Soil Humidity Geometric Average at Layer Interfac'
+#endif
+#if(GF)
+ write(21, *) '#GF SISVAT: Gravitational Saturation Front turned ON'
+#endif
+#if(GH)
+ write(21, *) '#GH SISVAT: Gravitational Saturation Front - Horton turned ON'
+#endif
+#if(OP)
+ write(21, *) '#OP SISVAT: Interactive Sea Surface Temperature turned ON'
+#endif
+#if(op)
+ write(21, *) '#op SISVAT: SST Nudging --> prescribed values turned ON'
+#endif
+ write(21, *) '#IP SISVAT: Sea-Ice Fraction prescribed from SMMR and SSM/I '
+ write(21, *) '#SI SISVAT: Sea-Ice Fraction calculated from prescribed SST '
+#if(IA)
+ write(21, *) '#IA SISVAT: Sea-Ice Bottom accretion and ocean cooling '
+#endif
+#if(MT)
+ write(21, *) '#MT SISVAT: Monin-Obukhov Theory is linearized (Garrat schem)'
+#endif
+#if(SR)
+ write(21, *) '#SR SISVAT: traces & OUTPUT a variable among called routines '
+#endif
+#if(WV)
+ write(21, *) '#WV SISVAT: performs OUTPUT on an ASCII File (1 file each pt)'
+#endif
+ write(21, *) '#sa SISVAT: must be pre-processed, except for stand-alone run'
+#if(CS)
+ write(21, *) '#CS INPUT: Constant Sounding during 1st Hours (2-D ONLY)'
+#endif
+ write(21, *) '#IB OUTPUT: Ice-Sheet Surface Mass Balance (on MARphy File )'
+ write(21, *) '#ID OUTPUT: Main Dependant Variables (on NetCDF File )'
+ write(21, *) '#UL OUTPUT: Time Dimension is UNLIMITED (on NetCDF File )'
+#if(T2)
+ write(21, *) '#T2 OUTPUT: 2-m Air Temperature (on NetCDF File )'
+#endif
+#if(W6)
+ write(21, *) '#W6 OUTPUT, Additional: Simulation Statistics on MAR.log'
+#endif
+#if(w6)
+ write(21, *) '#w6 OUTPUT, Additional: Simulation Statistics (NH) on MAR.log'
+#endif
+#if(WA)
+ write(21, *) '#WA OUTPUT, Additional: DYNadv_ver'
+#endif
+#if(WR)
+ write(21, *) '#WR OUTPUT, Additional: INIsnd, infra, SRFmod_sno, SRFmod_pol'
+#endif
+ write(21, *) '#vL PORTABILITY: Vectorization enhanced '
+ write(21, *) '#vN PORTABILITY: Vectorization enhanced: Leap Frog Counter '
+ write(21, *) '#vK PORTABILITY: Vectorization enhanced: TKE '
+ write(21, *) '#vH PORTABILITY: Vectorization enhanced: Hydrological Cycle '
+#if(vB)
+ write(21, *) '#vB PORTABILITY: Vectorization enhanced: Blowing Snow * '
+#endif
+#if(vD)
+ write(21, *) '#vD PORTABILITY: Vectorization enhanced: Blowing Dust . '
+#endif
+#if(vR)
+ write(21, *) '#vR PORTABILITY: Vectorization enhanced: Sastrugi Height '
+#endif
+ write(21, *) '#vS PORTABILITY: Vectorization enhanced: Snow Model '
+ write(21, *) '#vV PORTABILITY: Vectorization enhanced: SVAT '
+ write(21, *) '#vZ PORTABILITY: Vectorization enhanced: Av.Roughness Length '
+ write(21, *) '#HP PORTABILITY: Enables use of own library on Linux Syst.'
+ write(21, *) '#NV PORTABILITY: Vectorization is turned OFF '
+#if(iso)
+ write(21, *) '#iso Tracers: Water isotopes '
+#endif
+ write(21, 602) &
+ reaVAR, swich(-zext(reaVAR)), reaLBC, swich(-zext(reaLBC)), &
+ safVAR, swich(-zext(safVAR)), hamfil, swich(-zext(hamfil))
+602 format(//, ' OPTIONS', /, ' +++++++', /, &
+ /, ' reaVAR=', l2, 4x, ' => Input: Prev.Dyn.Sim.(MAR/GCM) ', a3, &
+ /, ' reaLBC=', l2, 4x, ' => LBC: Prev.Dyn.Sim.(MAR/GCM) ', a3, &
+ /, ' safVAR=', l2, 4x, ' => Saving on Files MARxxx.DAT ', a3, &
+ /, ' hamfil=', l2, 4x, ' => Diabatic Initialisation ', a3)
+#if(HF)
+ if(hamfil) write(21, 603) hham, nham, hhac, thac
+603 format( &
+ ' Hamming Filter Characteristics:', &
+ /, ' Time =', f11.4, '=> N(Hamming)= ', i12, &
+ /, ' Cutoff =', f11.4, '=> Frequency = ', f12.4, /, 1x)
+#endif
+ rhcrit = 0.0
+ tstart = 0.0
+ rhcrit = rhcrHY
+ tstart = tim_HY
+ write(21, 604) &
+ conmas, swich(-zext(conmas)), potvor, swich(-zext(potvor)), &
+ brocam, swich(-zext(brocam)), turhor, swich(-zext(turhor)), &
+ convec, swich(-zext(convec)), &
+ micphy, swich(-zext(micphy)), 1.d+2 * rhcrit, tstart, &
+ fracld, swich(-zext(fracld)), &
+ chimod, swich(-zext(chimod)), &
+ physic, swich(-zext(physic)), &
+ snomod, swich(-zext(snomod)), polmod, swich(-zext(polmod)), fxlead, &
+ vegmod, swich(-zext(vegmod)), qsolSL, swich(-zext(qsolSL)), &
+ rxbase, rxfact
+604 format( &
+ ' conmas=', l2, 4x, ' => Mass Conservation Constraint ', a3, &
+ /, ' potvor=', l2, 4x, ' => PV Conservation Constraint ', a3, &
+ /, ' brocam=', l2, 4x, ' => Brown and Campana Time Scheme ', a3, &
+ /, ' turhor=', l2, 4x, ' => Horizontal Diffusion ', a3, &
+ /, ' convec=', l2, 4x, ' => Mass Flux convective Scheme ', a3, &
+ /, ' micphy=', l2, 4x, ' => Cloud Microphysics ', a3, &
+ /, ' rhcrHY=', f6.0, ' % Critical Relative Humidity Value ', &
+ /, ' tim_HY=', f6.0, ' Cloud Microphysics Starting Time ', &
+ /, ' fracld=', l2, 4x, ' => Fractional Cloudiness Scheme ', a3, &
+ /, ' chimod=', l2, 4x, ' => Chemical Atmospheric Model ', a3, &
+ /, ' physic=', l2, 4x, ' => Atmosphere / Surface Physics ', a3, &
+ /, ' snomod=', l2, 4x, ' => Interactive Snow Model ', a3, &
+ /, ' polmod=', l2, 4x, ' => Interactive Polynya Model ', a3, &
+ /, ' fxlead=', f5.2, ' Initial Minimal Lead Fraction ', &
+ /, ' vegmod=', l2, 4x, ' => Interactive SVAT Model ', a3, &
+ /, ' qsolSL=', l2, 4x, ' => Soil Humidity Model ', a3, &
+ /, ' rxbase=', f6.3, ' Nudging Coeff.(Anthes et al. 1989)', &
+ /, ' rxfact=', f6.1, ' Lateral Sponge Coefficient (A89)')
+ write(21, 605) dx, mx, dy, my, &
+ dt, dtfast, ntFast, &
+ center, nordps, staggr, &
+ dtRadi, jtRadi, ntRadi, &
+ dtPhys, jtPhys, ntPhys, &
+ dtDiff, jtDiff, ntDiff, &
+ FIslot, FIkhmn, TUkhff, TUkhmx, FIslou, FIslop
+605 format(//, ' MAR DISCRETISATION', /, ' ++++++++++++++++++', &
+ //, ' dx =', f8.1, ' m / Nb Points : ', i12, &
+ /, ' dy =', f8.1, ' m / Nb Points : ', i12, &
+ /, ' dt =', f8.1, ' sec', &
+ /, ' dt Lamb =', f8.1, ' sec', &
+ /, ' nt Lamb =', i6, &
+ /, ' p* Discret.=', l6, 5x, ' / p* Precis.= ', i12, &
+ /, ' Vert.Stagg.=', l6, &
+ //, ' dt Sol./IR =', f8.1, ' sec => jt Sol./IR= ', i12, &
+ /, ' nt Sol./IR= ', i12, &
+ //, ' dt Surface =', f8.1, ' sec => jt Surface= ', i12, &
+ /, ' nt Surface= ', i12, &
+ /, ' CAUTION: := dt', &
+ //, ' dt Turbul. =', f8.1, ' sec => jt Turbul.= ', i12, &
+ /, ' / nt Turbul.= ', i12, &
+ /, ' CAUTION: := dt', &
+ //, ' delta T =', f11.4, ' => Kh(delta) = ', e12.4, &
+ /, ' ', 11x, ' -- fac. (Kh) = ', f12.4, &
+ /, ' Absorbing Layer -> Kh max = ', e12.4, &
+ /, ' delta u =', f11.4, &
+ /, ' delta p =', f11.4)
+ endif
+ ! +
+ ! +--WARNINGS
+ ! + ========
+ ! +
+ ! +--Time Step
+ ! + ---------
+ ! +
+ ! if (abs(dt-dtdom) > epsi) write(6,2) dt,dtdom
+ !2 format(/,' ***********************************',
+ ! . '********************************',
+ ! . /,' * CAUTION: dt(MARctr.dat)=',f8.2,'s',
+ ! . ' /= dt(MARdom.dat)=',f8.2,'s *',
+ ! . /,' ***********************************',
+ ! . '********************************',/,1x)
+ ! +
+ ! +
+ ! +--Topography
+ ! + ----------
+ ! +
+ lo_CAU = 0
+ if(n7mxLB > 1) then
+ do j = 1, my
+ do i = 1, n7mxLB - 1
+ if(abs(sh(i, j) - sh(ip1(i), j)) > epsi) lo_CAU = 1
+ enddo
+ enddo
+ endif
+ ! +
+ if(n6mxLB > 0) then
+ do j = 1, my
+ do i = mx - n6mxLB + 1, mx
+ if(abs(sh(i, j) - sh(im1(i), j)) > epsi) lo_CAU = 1
+ enddo
+ enddo
+ endif
+ ! +
+ if(n7myLB > 1) then
+ do j = 1, n7myLB - 1
+ do i = 1, mx
+ if(abs(sh(i, j) - sh(i, jp1(j))) > epsi) lo_CAU = 1
+ enddo
+ enddo
+ endif
+ ! +
+ if(n6myLB > 0) then
+ do i = 1, mx
+ do j = my - n6myLB + 1, my
+ if(abs(sh(i, j) - sh(i, jm1(j))) > epsi) lo_CAU = 1
+ enddo
+ enddo
+ endif
+ ! +
+ if(lo_CAU == 1) then
+ write(6, 1)
+1 format(' ******************************************************************', &
+ /, ' * CAUTION: Lateral Sponge too large OR Lateral Plateau too small *', &
+ /, ' ******************************************************************', /, 1x)
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ INITIALISATION INCLUDING A SAVED STATE OF THE VARIABLES ++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ if(reaVAR) then
+ ! +--Timing
+ ! + ======
+ iterun = 0
+ ! +--Dynamics
+ ! + ========
+ open(unit=11, status='old', form='unformatted', file='MARdyn.DAT')
+ rewind 11
+ ! In the coupled MAR/ice sheet model simulation, itexpe must be an integer*8 in MARCTR.inc
+ ! If you started your simulation with an interger*4, you need only 1 time to use
+ ! the "itexpe2" line to read an integer*4 but to save an integer*8 for the next simulation.
+ ! Afterwards, you have to use the "itexpe" line to read/write an interger*8
+ ! ------------------------------------------------------------------------------------------ !
+ ! if itexpe is integer*8 but file in integer*4
+ ! read(11) itexpe2,jdh_LB ; itexpe=itexpe2
+ ! if itexpe is integer*4 / *8
+ read(11) itexpe, jdh_LB
+ ! ------------------------------------------------------------------------------------------ !
+ ! +... Time Parameters
+ read(11) iyrDYN, mmaDYN, jdaDYN, jhuDYN
+ ! +--Modified Time Step (BEGIN)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~
+ YYtmp = -1
+ MMtmp = -1
+ DDtmp = -1
+ dt_old = -1
+ dt_new = -1
+ open(unit=51, status='old', file='MARtime.ctr', err=51)
+ read(51, *, err=51) YYtmp, MMtmp, DDtmp, dt_old, dt_new
+51 continue
+ close(51)
+ if(YYtmp == iyrDYN .and. MMtmp == mmaDYN .and. &
+ DDtmp == jdaDYN .and. dt_old > 0 .and. dt_new > 0) then
+ write(6, *) ' '
+ write(6, *) 'WARNING--WARNING--WARING--WARING--WARNING'
+ write(6, *) 'itexpe modified by MARtime.ctr'
+ write(6, *) 'dt_old =', dt_old
+ write(6, *) 'dt_new =', dt_new
+ write(6, *) 'WARNING--WARNING--WARING--WARING--WARNING'
+ write(6, *) ' '
+ itexpe = (itexpe * dt_old) / dt_new
+ endif
+ ! +--Modified Time Step (end)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! Spatial Parameters
+ read(11) imezdy, jmezdy
+ read(11) aladyn, alodyn
+ ! Discretisation
+ read(11) sigma, ptopDY, dx, dy
+ ! Dynamics
+ read(11) uairDY
+ read(11) vairDY
+ read(11) pktaDY
+ read(11) pstDY
+ read(11) qvDY
+ read(11) sh
+#if(GL)
+ ! MAR-GRISLI coupling
+ call ice_sheet_model_coupling
+#endif
+ read(11) pstDY1
+ ! Lateral Boundary Conditions
+ read(11) iyr_LB, mma_LB, jda_LB, jhu_LB, jdh_LB
+ read(11) vaxgLB, vaxdLB, vayiLB, vaysLB
+ read(11) sst_LB
+ ! Upper Sponge Reference State
+ read(11) uairUB, vairUB, pktaUB
+ if(jdh_LB <= 0) then
+ ! write(6,6000) jdh_LB
+! 6000 format(/, '##############################################', &
+! /, '# CAUTION: previous jdh_LB =', i6, ' set:= 1 #', &
+! /, '##############################################',/)
+ jdh_LB = 1
+ endif
+ if(itexpe > 0) then
+ read(11) pstDYn
+ read(11) RAd_ir
+ read(11) IRsoil
+ read(11) virDY
+ read(11) tim1LB, v1xgLB, v1xdLB, v1yiLB, v1ysLB
+ read(11) tim2LB, v2xgLB, v2xdLB, v2yiLB, v2ysLB
+ read(11) sst1LB, sst2LB
+ read(11) ua1_UB, ua2_UB
+ read(11) va1_UB, va2_UB
+ read(11) pkt1UB, pkt2UB
+ if(my == 1) then
+ read(11) ugeoDY
+ read(11) vgeoDY
+#if(PV)
+ stop ' ?!&~@|@[#@# PV not conserved! EMERGENCY STOP'
+#endif
+ endif
+ endif
+ close(unit=11)
+#if(iso)
+ if(itexpe == 0) then
+ call mariso_init_dy(iso_init_type, qvDY, qvDY_iso)
+ else
+ ! read isotopic composition of dynamical variables
+ open(unit=11, status='old', form='unformatted', file='MARdyn_iso.DAT')
+ rewind 11
+ read(11) qvDY_iso
+ close(unit=11)
+ endif
+#endif
+
+ ! +--sigma-levels Height
+ ! + -------------------
+ do k = 1, mz
+ zsigma(k) = -(sst_SL / 0.0065) * ((1.e0 + (sigma(k) - 1.) &
+ * (1.e2 / ps_sig)) &
+ **(RDryAi * 0.0065 / gravit) - 1.)
+ enddo
+ if(IO_gen >= 2) then
+ write(21, 130)(sigma(k), k=1, mz)
+ write(21, 131)(zsigma(k), k=1, mz)
+ endif
+
+ ! +--Auxiliary Grid Parameters
+ ! + -------------------------
+ ! + ******
+ call grdmar
+ ! + ******
+
+ ! +--Geographical Coordinates
+ ! + ------------------------
+ ! + ******
+ call grdgeo
+ ! + ******
+
+ ! +--Local Time of the Model Center
+ ! + ------------------------------
+ ! + ******
+ call timcur
+ call timgeo
+ ! + ******
+
+ ! +--LBC Coefficients
+ ! + ----------------
+ if(itexpe == 0) then
+ tim1LB = ou2sGE(iyr_LB, mma_LB, jda_LB, jhu_LB, 0, 0)
+ tim2LB = tim1LB
+ do iv_ini = 1, 5
+ do i = 1, n7mxLB
+ do k = 1, mz
+ do j = 1, my
+ v1xgLB(i, j, k, iv_ini) = vaxgLB(i, j, k, iv_ini)
+ v2xgLB(i, j, k, iv_ini) = vaxgLB(i, j, k, iv_ini)
+ enddo
+ enddo
+ enddo
+ do i = mx - n6mxLB, mx
+ do k = 1, mz
+ do j = 1, my
+ v1xdLB(i, j, k, iv_ini) = vaxdLB(i, j, k, iv_ini)
+ v2xdLB(i, j, k, iv_ini) = vaxdLB(i, j, k, iv_ini)
+ enddo
+ enddo
+ enddo
+ do j = 1, n7myLB
+ do k = 1, mz
+ do i = 1, mx
+ v1yiLB(i, j, k, iv_ini) = vayiLB(i, j, k, iv_ini)
+ v2yiLB(i, j, k, iv_ini) = vayiLB(i, j, k, iv_ini)
+ enddo
+ enddo
+ enddo
+ do j = my - n6myLB, my
+ do k = 1, mz
+ do i = 1, mx
+ v1ysLB(i, j, k, iv_ini) = vaysLB(i, j, k, iv_ini)
+ v2ysLB(i, j, k, iv_ini) = vaysLB(i, j, k, iv_ini)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! + **********
+ call lbcnud_ini
+ ! + **********
+
+ ! + **********
+ call lbcnud_par
+ ! + **********
+
+ ! +--Soil Model
+ ! + ==========
+ open(unit=11, status='old', form='unformatted', file='MARsol.DAT')
+ rewind 11
+ read(11) itever
+ read(11) iyrSOL, mmaSOL, jdaSOL, jhuSOL
+ if(itever /= itexpe .or. &
+ iyrSOL /= iyrDYN .or. &
+ mmaSOL /= mmaDYN .or. &
+ jdaSOL /= jdaDYN .or. &
+ jhuSOL /= jhuDYN) then
+ write(6, 817)
+817 format(' ++WARNING++ MARsol improperly specified ')
+ endif
+ read(11) nSLsrf
+ read(11) SLsrfl
+ read(11) TairSL
+ read(11) tsrfSL
+ read(11) alb0SL, eps0SL
+ read(11) SaltSL
+ read(11) ro_SL0
+ read(11) ro_SL
+ read(11) d1_SL
+ read(11) t2_SL
+ read(11) w2_SL, wg_SL
+ read(11) roseSL
+ read(11) qvapSL
+ read(11) hsnoSL
+ read(11) hmelSL
+ read(11) SLuusl, SL_z0
+ read(11) SLutsl, SL_r0
+ if(itexpe > 0) then
+ read(11) pktaSL
+ read(11) sicsIB
+ read(11) sic1sI, sic2sI
+ read(11) albeSL
+ read(11) SLuus, SLuts
+ read(11) SLuqs, SLuqsl
+ read(11) duusSL
+ read(11) dutsSL
+ read(11) cdmSL, cdhSL
+ read(11) V_0aSL
+ read(11) dT0aSL
+#if(AM)
+ read(11) u_0aSL
+#endif
+#if(AT)
+ read(11) uT0aSL
+#endif
+#if(AS)
+ read(11) us0aSL
+#endif
+#if(VX)
+ read(11) WV__SL
+#endif
+ read(11) SLlmo, SLlmol
+#if(BV)
+ read(11) virSL
+#endif
+ endif
+ close(unit=11)
+#if(iso)
+ if(itexpe == 0) then
+ call mariso_init_sl(iso_init_type, qvapSL, qvapSL_iso)
+ else
+ ! read isotopic composition of surface air water
+ open(unit=11, status='old', form='unformatted', file='MARsol_iso.DAT')
+ rewind 11
+ read(11) qvapSL_iso
+ read(11) SLuqs_iso
+ read(11) SLuqsl_iso
+ close(unit=11)
+ endif
+#endif
+ if(itexpe == 0) then
+ open(unit=11, status='old', form='unformatted', file='MARsic.DAT')
+ rewind 11
+ read(11) iyr_sI, mma_sI, jda_sI, jhu_sI, jdh_sI
+ read(11) sicsIB
+ close(unit=11)
+ endif
+ ! +--Update of Soil Parameters
+ ! + -------------------------
+ Tfr_LB = tfrwat
+#if(RE)
+ Tfr_LB = tfrwat + 0.15 + epsi
+#endif
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) <= 2) then
+ ! +---1. Open Water
+ ! + ~~~~~~~~~~~~~
+ if(sst_LB(i, j) >= Tfr_LB) then
+ isolSL(i, j) = 1
+ d1_SL(i, j) = 2.09e+8
+ albeSL(i, j) = 0.10
+ eps0SL(i, j) = 0.97
+ SL_z0(i, j, 1) = zs_SL
+ SL_r0(i, j, 1) = 0.1 * zs_SL
+ ch0SL(i, j) = 0.00132
+ rsurSL(i, j) = 0.0
+ else
+ ! +---2. Sea Ice
+ ! + ~~~~~~~~~~
+ ! (Kondo and Yamazaki, 1990, JAM 29, p.376)
+ isolSL(i, j) = 2
+ d1_SL(i, j) = 1.05e+5
+ albeSL(i, j) = 0.70
+ eps0SL(i, j) = 0.97
+ SL_z0(i, j, 1) = zn_SL
+ SL_r0(i, j, 1) = 0.1 * zn_SL
+ ch0SL(i, j) = 0.0021
+ rsurSL(i, j) = 0.0
+ endif
+ endif
+ enddo
+ enddo
+
+ ! +--SVAT Model
+ ! + ==========
+ if(vegmod) then
+ ! + ***********
+ call svasav('read')
+ ! + ***********
+ endif
+
+#if(AO)
+ ! +--Ocean Model
+ ! + ===========
+ !AO_CK 20/02/2020
+ ! +--cpl Get fields from oasis initialisation files
+ ! + ----------------------------------------------
+ ! il_time_secs : temps depuis le debut du run (au pas de temps precedant)
+ il_time_secs = 0
+ ! +--read fields from NEMO at 1st time step of this run
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ write(6, *) ' call fromcpl, itexpe =', itexpe
+ write(6, *) ' call fromcpl, il_time_secs =', il_time_secs
+
+ call fromcpl(il_time_secs, srftAO(:, :, 1), aoss, &
+ sicsAO, aogla, albAO(:, :, 2), aoalb, srftAO(:, :, 2), aotic, &
+ hicAO, aohic, hsnoAO, aohsn, UoceAO, ao_uo, VoceAO, ao_vo, &
+ UiceAO, ao_ui, ViceAO, ao_vi)
+ ! + *******
+ ! tocken_AO : not to call fromcpl further at the first time step
+ tocken_AO = 1
+
+ !No need to check if fields have been updated as they came from restart files (=update)
+ print *, "AO/coupling: warning on your first restart files"
+ do j = 1, my
+ do i = 1, mx
+ ! +--NEMO temperature
+ if(weightao_sst(i, j) /= 1) then
+ srftAO(i, j, 1) = min(max(srftAO(i, j, 1) / (1 - sicsAO(i, j)) &
+ , 271.01), 300.15)
+ sst_LB(i, j) = (1.-weightao_sst(i, j)) * srftAO(i, j, 1) &
+ + (weightAO_sst(i, j) * sst_LB(i, j))
+ endif
+ ! +--NEMO SIC
+ if(weightao_sic(i, j) /= 1) then
+ sicsIB(i, j) = (1.-weightao_sic(i, j)) * sicsAO(i, j) &
+ + (weightAO_sic(i, j) * sicsIB(i, j))
+ endif
+ enddo
+ enddo
+
+ ! +--NEMO other parameters:
+ ! snow and sea ice thickness, albedo
+ ! => not coupled at ini of MAR to increase MAR stability
+ ! (one thing at a time) #CK
+ ! SST/ Sea ice Surface temperature cf below
+
+ ! +--Open Water Albedo
+ ! + -----------------
+ if(itexpe == 0) then
+ do i = 1, mx
+ do j = 1, my
+ ! open water albedo prescribed at first time step
+ albAO(i, j, 1) = 0.066
+ ! clear sky value in flx_core.h90 (NEMO)
+ enddo
+ enddo
+ ! ck not sure that is still needed
+ do i = 1, mx
+ do j = 1, my
+ if(sicsIB(i, j) == 0) then
+ ! where no sea ice, albedo begin with
+ ! value (taking into account solar ze cloud cover)
+ albAO(i, j, 1) = albeSL(i, j)
+ else
+ ! elsewhere, albedo ove
+ ! and albedo over ice is NEMO's albed
+ ! by sending solar zenith angle and c
+ ! so that it computes himself ocean a
+ albAO(i, j, 1) = 0.066
+ endif
+ enddo
+ enddo
+ endif
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) <= 2) then
+ albsSL(i, j) = albAO(i, j, 1) * (1.-sicsAO(i, j)) &
+ + albAO(i, j, 2) * sicsAO(i, j)
+ albeSL(i, j) = albsSL(i, j)
+ endif
+ enddo
+ enddo
+ do i = 1, mx
+ do j = 1, my
+ if(isolSL(i, j) <= 2) then
+ maskSL(i, j) = 1 !ocean/sea-ice
+ do n = 1, 2
+ ! to be sure that they have a value => tairdy(i,j,mz)
+ if(i == 1) tsrfSL(i, j, n) = tairDY(i, j, mz)
+ if(j == 1) tsrfSL(i, j, n) = tairDY(i, j, mz)
+ if(i == mx) tsrfSL(i, j, n) = tairDY(i, j, mz)
+ if(j == my) tsrfSL(i, j, n) = tairDY(i, j, mz)
+ tsrfSL(i, j, n) = srftAO(i, j, n) * (1.-weightao_st(i, j)) &
+ + (weightAO_st(i, j) * tsrfSL(i, j, n))
+
+ do isl = -nsol, 0
+ if(n == 1) then !ocean
+ ! Prescribed SST
+ TsolTV(i, j, n, 1 - isl) = tsrfSL(i, j, n)
+ SLsrfl(i, j, n) = 1.-sicsIB(i, j)
+ endif
+ if(n == 2) then
+ ! sea ice
+ ! Prescribed SST beneath Ice
+ TsolTV(i, j, n, 1 - isl) = 271.2
+ SLsrfl(i, j, n) = sicsIB(i, j)
+ endif
+ enddo
+ enddo
+ else
+ ! land
+ maskSL(i, j) = 0
+ endif
+ enddo
+ enddo
+#endif
+ if(itexpe > 0) then
+#if(NH)
+ ! +--Non-Hydrostatic Dynamics
+ ! + ========================
+ open(unit=11, status='unknown', form='unformatted', file='MARonh.DAT')
+ rewind 11
+ ! Time Parameters
+ read(11) itever
+ read(11) iyrONH, mmaONH, jdaONH, jhuONH
+ if(itever /= itexpe .or. &
+ iyrONH /= iyrDYN .or. &
+ mmaONH /= mmaDYN .or. &
+ jdaONH /= jdaDYN .or. &
+ jhuONH /= jhuDYN) write(6, 810)
+810 format(' ++WARNING++ MARonh improperly specified ')
+ ! +... Dynamics
+ read(11) wa0_NH
+ read(11) ua0_NH
+ read(11) va0_NH
+ read(11) wairNH
+ read(11) pairNH
+ close(unit=11)
+#endif
+ ! +--Mass Flux convective Scheme
+ ! + ===========================
+ if(convec) then
+ open(unit=11, status='old', form='unformatted', file='MARcva.DAT')
+ rewind 11
+ read(11) itever
+ ! Time Parameters
+ read(11) iyrCVA, mmaCVA, jdaCVA, jhuCVA
+ if(itever /= itexpe .or. &
+ iyrCVA /= iyrDYN .or. &
+ mmaCVA /= mmaDYN .or. &
+ jdaCVA /= jdaDYN .or. &
+ jhuCVA /= jhuDYN) then
+ write(6, 811)
+811 format(' ++WARNING++ MARcva improperly specified ')
+ endif
+ read(11) adj_CA
+ read(11) int_CA
+ read(11) dpktCA
+ read(11) dqv_CA
+ read(11) dqw_CA
+ read(11) dqi_CA
+ read(11) drr_CA
+ read(11) dss_CA
+ read(11) dsn_CA
+ read(11) rainCA
+ read(11) snowCA
+ read(11) tau_CA
+ read(11) Kstep1
+ read(11) K_CbT1
+ read(11) K_CbB1
+ read(11) P_CH_0
+ read(11) PdCH_1
+ read(11) PdTa_1
+ read(11) PdQa_1
+ read(11) PdQw_1
+ read(11) PdQi_1
+ read(11) Pdrr_1
+ read(11) Pdss_1
+ read(11) PuMF_1
+ read(11) PdMF_1
+ read(11) Pfrr_1
+ read(11) Pfss_1
+ read(11) Pcape1
+ close(unit=11)
+#if(iso)
+ ! read isotopic composition of convective variables
+ open(unit=11, status='old', form='unformatted', file='MARcva_iso.DAT')
+ rewind 11
+ read(11) dqv_CA_iso
+ read(11) dqw_CA_iso
+ read(11) dqi_CA_iso
+ read(11) drr_CA_iso
+ read(11) dss_CA_iso
+ read(11) dsn_CA_iso
+ read(11) rainCA_iso
+ read(11) snowCA_iso
+ close(unit=11)
+#endif
+ endif
+
+ ! +--Microphysics
+ ! + ============
+ if(micphy) then
+ open(unit=11, status='old', form='unformatted', file='MARcld.DAT')
+ rewind 11
+ read(11) itever
+ read(11) iyrHYD, mmaHYD, jdaHYD, jhuHYD
+ if(itever /= itexpe .or. &
+ iyrHYD /= iyrDYN .or. &
+ mmaHYD /= mmaDYN .or. &
+ jdaHYD /= jdaDYN .or. &
+ jhuHYD /= jhuDYN) write(6, 812)
+812 format(' ++WARNING++ MARcld improperly specified ')
+ ! +
+ read(11) turnHY
+ read(11) ccniHY
+ read(11) qiHY
+ read(11) qsHY
+ ! +HG read(11) qgHY
+ read(11) qwHY
+ read(11) qrHY
+ read(11) rainHY, rai0HY
+ read(11) snowHY, sno0HY, sfa0HY
+ read(11) crysHY
+ read(11) rainCA
+#if(BS)
+ read(11) uss_HY
+#endif
+ close(unit=11)
+#if(iso)
+ ! read isotopic composition of microphysics water
+ open(unit=11, status='old', form='unformatted', file='MARcld_iso.DAT')
+ rewind 11
+ read(11) qiHY_iso
+ read(11) qsHY_iso
+ read(11) qwHY_iso
+ read(11) qrHY_iso
+ read(11) rainHY_iso, rai0HY_iso
+ read(11) snowHY_iso, sno0HY_iso, sfa0HY_iso
+ read(11) crysHY_iso
+ ! rainCA_iso already in 'MARcva_iso.DAT'
+ ! read(11) rainCA_iso
+ close(unit=11)
+#endif
+ endif
+#if(TC)
+ ! +--Atmospheric Tracers
+ ! + ===================
+ open(unit=11, status='old', form='unformatted', file='MARtca.DAT')
+ rewind 11
+ read(11) itever
+ read(11) iyrTCA, mmaTCA, jdaTCA, jhuTCA
+ read(11) dt_ODE, dt2ODE, nt_ODE, jt_ODE
+ if(itever /= itexpe .or. &
+ iyrTCA /= iyrDYN .or. &
+ mmaTCA /= mmaDYN .or. &
+ jdaTCA /= jdaDYN .or. &
+ jhuTCA /= jhuDYN) write(6, 813)
+813 format(' ++WARNING++ MARtca improperly specified ')
+ read(11) qxTC
+ read(11) qsTC
+ read(11) uqTC
+ close(unit=11)
+#endif
+#if(PO)
+ ! +--Polynya Model
+ ! + =============
+ if(polmod) then
+ open(unit=11, status='old', form='unformatted', file='MARpol.DAT')
+ rewind 11
+ read(11) itever
+ read(11) iyrPOL, mmaPOL, jdaPOL, jhuPOL
+ if(itever /= itexpe .or. &
+ iyrPOL /= iyrDYN .or. &
+ mmaPOL /= mmaDYN .or. &
+ jdaPOL /= jdaDYN .or. &
+ jhuPOL /= jhuDYN) then
+ write(6, 814)
+814 format(' ++WARNING++ MARpol improperly specified ')
+ endif
+ read(11) isolSL
+ read(11) iPO1, iPO2, jPO1, jPO2, iPO3, iPO4, jPO3, jPO4
+ read(11) hfraPO, vgriPO, uocnPO, vocnPO, swsaPO, focnPO
+ read(11) silfPO, hicePO, aicePO, uicePO, vicePO, dtPO
+ close(unit=11)
+ endif
+#endif
+ ! +--Turbulence
+ ! + ==========
+ open(unit=11, status='old', form='unformatted', file='MARtur.DAT')
+ rewind 11
+ read(11) itever
+ read(11) iyrTUR, mmaTUR, jdaTUR, jhuTUR
+ if(itever /= itexpe .or. &
+ iyrTUR /= iyrDYN .or. &
+ mmaTUR /= mmaDYN .or. &
+ jdaTUR /= jdaDYN .or. &
+ jhuTUR /= jhuDYN) then
+ write(6, 816)
+816 format(' ++WARNING++ MARtur improperly specified ')
+ endif
+ ! TURBULENT KINETIC ENERGY (TKE) and DISSIPATION (e)
+ read(11) ect_TE
+ read(11) eps_TE
+ read(11) tranTE
+ ! TURBULENT DifFUSION COEFFICIENT
+ read(11) TUkvm
+ read(11) TUkvh
+ close(unit=11)
+ else
+ ! +--Timing
+ ! + ======
+ itexpe = 0
+ iterun = 0
+ ! +--Atmosphere
+ ! + ==========
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ pstDYn(i, j) = pstDY(i, j)
+ enddo
+ enddo
+ ! + *********
+ call dyngpo_mp
+ ! + *********
+ ! +--Microphysics and Surface
+ ! + ========================
+ ! + ******
+ call iniphy
+ ! + ******
+ ! +--Water Vapor and Precipitation Loading
+ ! + -------------------------------------
+ ! + ******
+ call dynloa
+ ! + ******
+ ! +--Surface Albedo (set to underlaying Soil Albedo)
+ ! + --------------
+ do j = 1, my
+ do i = 1, mx
+ alb0SL(i, j) = max(albsSL(i, j), alb0SL(i, j))
+ albeSL(i, j) = max(albsSL(i, j), albeSL(i, j))
+ enddo
+ enddo
+ endif
+ else
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ INITIALISATION INCLUDING A SOUNDING ++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! cCAiso : no isotope for sounding
+ ! +--Timing
+ ! + ======
+ itexpe = 0
+ iterun = 0
+ ! +--Dynamics
+ ! + ========
+ ! +--Vertical Grid Initialisation
+ ! + -----------------------------
+ ! + ******
+ if(.not. geoNST) call grdsig(zmin_0, aavu_0, bbvu_0, ccvu_0, verti0)
+ ! + ******
+ ! +
+ ! +--Auxiliary Grid Parameters
+ ! + -------------------------
+ ! + ******
+ call grdmar
+ ! + ******
+ ! +
+ ! +--Geographical Coordinates
+ ! + ------------------------
+ ! + ******
+ call grdgeo
+ ! + ******
+ ! +
+ ! +--Local Time of the Model Center
+ ! + ------------------------------
+ ! + ******
+ call timcur
+ call timgeo
+ ! + ******
+ ! +
+ ! +--Initialisation assuming horizontal Homogeneity
+ ! + ----------------------------------------------
+ ! + ******
+ call inisnd
+ ! + ******
+ ! +
+ ! + **********
+ call lbcnud_ini
+ ! + **********
+ ! +
+ ! + **********
+ call lbcnud_par
+ ! + **********
+ ! +
+ ! +--Leapfrog Auxiliary Variables
+ ! + ============================
+ do j = 1, my
+ do i = 1, mx
+ pstDYn(i, j) = pstDY(i, j)
+ enddo
+ enddo
+ ! +
+ ! +--Microphysics and Surface
+ ! + ========================
+ ! + ******
+ call iniphy
+ ! + ******
+ ! +
+ ! +--Water Vapor and Precipitation Loading
+ ! + -------------------------------------
+ ! + ******
+ call dynloa
+ ! + ******
+ ! +
+ ! +--Surface Albedo (set to underlaying Soil Albedo)
+ ! + --------------
+ do j = 1, my
+ do i = 1, mx
+ alb0SL(i, j) = max(albsSL(i, j), alb0SL(i, j))
+ albeSL(i, j) = max(albsSL(i, j), albeSL(i, j))
+ enddo
+ enddo
+ endif
+ ! +
+ ! +
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ AUXILIARY VARIABLES INITIALISATION +++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +
+ ! +
+ ! +--Parameters
+ ! + ==========
+ ! +
+ ipri = 0
+ ! +... print parameter used in Model Validation
+ ! + on Linear Mountain Waves Simulations
+ ! +
+ ! +--Atmospheric variables
+ ! + =====================
+ ! +
+ ! +
+ ! +--Leapfrog Auxiliary Variables
+ ! + ----------------------------
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ubefDY(i, j, k) = uairDY(i, j, k)
+ vbefDY(i, j, k) = vairDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Surface Geopotential
+ ! + --------------------
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ gplvDY(i, j, mzz) = gravit * sh(i, j)
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Exner Potential, Temperature and Level Geopotential
+ ! + ---------------------------------------------------
+ ! +
+ ! + *********
+ call dyngpo_mp
+ ! + *********
+ ! +
+ ! +--Mid-Level Geopotential
+ ! + ----------------------
+ ! +
+ k = 1
+ do j = 1, my
+ do i = 1, mx
+ gpmiDY(i, j, k) = 0.5 * (3.5 * gplvDY(i, j, 1) - 0.5d0 * gplvDY(i, j, 2))
+ enddo
+ enddo
+ ! +
+ do k = kp1(1), mzz
+ do j = 1, my
+ do i = 1, mx
+ gpmiDY(i, j, k) = 0.5 * (gplvDY(i, j, k - 1) + gplvDY(i, j, k))
+ enddo
+ enddo
+ enddo
+ ! +
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ gpmiDY(i, j, k) = (0.5 * z__SBL + sh(i, j)) * gravit
+ enddo
+ enddo
+ ! +--Vertical Temperature Gradient at Sponge Base
+ ! + --------------------------------------------
+ ! +
+ gradTz = 1.0e+3 * grvinv
+ if(mzabso > 1) then
+ mzabs1 = max(mzabso - 1, 1)
+ do j = 1, my
+ do i = 1, mx
+ gradTz = min(gradTz,(tairDY(i, j, mzabs1) - tairDY(i, j, mzabso)) &
+ / (epsi + gplvDY(i, j, mzabs1) - gplvDY(i, j, mzabso)))
+ enddo
+ enddo
+ endif
+ gradTz = gradTz * gravit * 1.0d+3
+#if(OL)
+ ! +--Sigma Surfaces Initial Altitudes for Linear Mountain Wave Experiments
+ ! + ---------------------------------------------------------------------
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ gp00OL(i, j, k) = gplvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+#if(PE)
+ ! +--Slopes of the Sigma Surfaces
+ ! + ----------------------------
+ ! +
+ ! + ******
+ ! _PE call INIpen
+ ! + ******
+ ! +
+ ! cCA : subroutine INIpen not found
+ ! + ******
+ ! call INIpen
+ ! + ******
+ ! +
+ ! +
+#endif
+#if(Di)
+ ! +--Top / Bottom Boundaries
+ ! + -----------------------
+ ! +
+ ! do j=1,my
+ ! do i=1,mx
+ ! qvtoDI(i,j) = qvDY(i,j,1)
+ ! pkttDI(i,j) = pktaDY(i,j,1)
+ ! uairDI(i,j) = uairDY(i,j,1)
+ ! vairDI(i,j) = vairDY(i,j,1)
+ ! end do
+ ! end do
+#endif
+ ! +
+ ! +
+ ! +--Specific Mass
+ ! + -------------
+ ! + ******
+ call dynrho
+ ! + ******
+ ! +
+ ! +--Surface Variables
+ ! + =================
+ ! +
+ ! +--Land-Sea Mask
+ ! + -------------
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) <= 2) then
+ maskSL(i, j) = 1
+ else
+ maskSL(i, j) = 0
+ endif
+ enddo
+ enddo
+ ! +--OUTPUT
+ ! + ======
+ if(IO_loc >= 1) then
+ write(21, 606) jdaMAR, jhaMAR, itexpe, nboucl, nprint, &
+ 0.1 * pSND(1, 1), pstSND, sst_SL, dtagSL, &
+ zs_SL, zn_SL, gradtz, mzabso
+606 format(//, ' EXECUTION STATUS', /, ' ++++++++++++++++', /, &
+ /, ' Preceding Execution stopped after', i5, ' day(s)', i5, ' hour(s)', &
+ /, ' itexpe =', i8, 8x, ' nboucl =', i8, 8x, 'nprint =', i8, &
+ /, ' p MSL =', f8.1, ' cb', 5x, 'p* 0 =', f8.1, ' cb', &
+ /, ' SST =', f8.1, ' K ', 5x, 'T0-Tg =', f8.1, ' K ', &
+ /, ' zs =', f8.5, ' m ', 5x, 'zn =', f8.5, ' m ', &
+ /, ' dT/dz >=', f8.2, ' K/km / mzabso =', i8, ' Sponge Base')
+ if(gradtz < -4.0) write(6, 607) gradtz, mzabso
+607 format(/, ' WARNING: dT/dz Min =', f8.2, ' K/km at Sponge Base (k=mzabso=', i2, ')')
+ endif
+ return
+endsubroutine inigen
+
+integer function zext(logvar)
+ logical, intent(in) :: logvar
+ if(logvar) then
+ zext = -1
+ else
+ zext = 0
+ endif
+ return
+endfunction zext
diff --git a/MAR/code_mar/iniglf.f90 b/MAR/code_mar/iniglf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d58d517245a7124cf128e688f68b4abda562a987
--- /dev/null
+++ b/MAR/code_mar/iniglf.f90
@@ -0,0 +1,190 @@
+#include "MAR_pp.def"
+subroutine INIglf(ihamr_glf, nhamr_glf, newglfINI)
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT SVAT 7-06-2002 MAR |
+ ! | subroutine INIglf is used to initialize MAR Green Leaf Fractions |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: ihamr_glf: Time Digital Filter Status |
+ ! | ^^^^^ nhamr_glf: Time Digital Filter Set Up |
+ ! | |
+ ! | OUTPUT: newglfINI: (0,1) ==> (NO new glf , new glf) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | OUTPUT: alaiTV: Current Leaf Area Index (LAI)|
+ ! | ^^^^^^^ LAI1VB: Previous Nesting Time Step Leaf Area Index |
+ ! | LAI2VB: Next Nesting Time Step Leaf Area Index |
+ ! | glf_TV: Current Green Leaf Fraction (GLF)|
+ ! | glf1VB: Previous Nesting Time Step Green Leaf Fraction |
+ ! | glf2VB: Next Nesting Time Step Green Leaf Fraction |
+ ! | tim1VB,tim2VB: Times n, n+1 of LAI and GLF |
+ ! | |
+ ! | CAUTION: It is assumed that tim1VB and tim2VB do not change when the |
+ ! | ^^^^^^^^ Variables are reassigned after the dynamical Initialization |
+ ! | (Reassignation => itexpe := nham => timar := timar-nham*dt) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_sl
+ use mar_sv
+ use mar_tv
+ use mar_vb
+ ! +
+ implicit none
+
+ integer i, j, k, m
+ integer ihamr_glf, nhamr_glf
+ integer newglfINI
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ !XF
+ integer(kind=8) itisva, iv_glf
+ ! int*8 is needed for making future projections!!!!
+ real rate
+ ! +
+ ! +
+ ! +--Current Time
+ ! + ============
+ ! +
+ itisva = ou2sGE(iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, jsecGE)
+#if(HF)
+ itisva = itisva + (ihamr_glf + nhamr_glf) * idt
+#endif
+ ! +
+ ! +
+ ! +--Reinitialization of the Leaf Area Index and the Green Leaf Fraction
+ ! + -------------------------------------------------------------------
+ ! +
+ if(iterun == 0) then
+ jdh_VB = 1
+ iyr_VB = iyrrGE
+ mma_VB = mmarGE
+ jda_VB = jdarGE
+ jhu_VB = jhurGE
+ tim1VB = itisva
+ tim2VB = itisva
+ do iv_glf = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+#if(LN)
+ LAI1VB(i, j, iv_glf) = alaiTV(i, j, iv_glf)
+ LAI2VB(i, j, iv_glf) = alaiTV(i, j, iv_glf)
+#endif
+ glf1VB(i, j, iv_glf) = glf_TV(i, j, iv_glf)
+ glf2VB(i, j, iv_glf) = glf_TV(i, j, iv_glf)
+ enddo
+ enddo
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--New VBC
+ ! + =======
+ ! +
+ if(itisva > tim2VB) then
+ ! +
+ tim1VB = tim2VB
+ ! +
+ write(6, 6001) jda_VB, labmGE(mma_VB), iyr_VB, &
+ jhu_VB, tim1VB, &
+ jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itisva
+6001 format(/, ' 1st VBC /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/', 2x, &
+ ' t =', i12, 's A.P.', &
+ /, ' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12)
+ ! +
+ if(jdh_VB == 0) jdh_VB = -1
+ open(unit=11, status='old', form='unformatted', file='MARglf.DAT')
+ rewind 11
+11 continue
+ if(jdh_VB <= 0) go to 10
+ ! +
+ ! +
+ ! +--VBC at nesting time step n
+ ! + --------------------------
+ ! +
+ do iv_glf = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+#if(LN)
+ LAI1VB(i, j, iv_glf) = LAI2VB(i, j, iv_glf)
+#endif
+ glf1VB(i, j, iv_glf) = glf2VB(i, j, iv_glf)
+#if(LN)
+ LAI2VB(i, j, iv_glf) = 0.d0
+#endif
+ glf2VB(i, j, iv_glf) = 0.d0
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--VBC at nesting time step n+1
+ ! + ----------------------------
+ ! +
+ read(11) iyr_VB, mma_VB, jda_VB, jhu_VB, jdh_VB
+ read(11) glf2VB
+#if(LN)
+ read(11) LAI2VB
+#endif
+ ! +
+ tim2VB = ou2sGE(iyr_VB, mma_VB, jda_VB, jhu_VB, 0, 0)
+ ! +
+ if(itisva > tim2VB) go to 11
+ ! +
+ write(6, 6002) jda_VB, labmGE(mma_VB), iyr_VB, &
+ jhu_VB, jdh_VB, tim2VB
+6002 format(' 2nd VBC /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/(', i1, &
+ ') t =', i12, /, 1x)
+ ! +
+10 continue
+ close(unit=11)
+ ! +
+ else
+#if(WR)
+ write(6, 6003) jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itisva
+#endif
+6003 format(' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12, 's A.P.')
+ endif
+ ! +
+ ! +
+ ! +--Time Interpolation
+ ! + ==================
+ ! +
+ if(itisva <= tim2VB .and. tim1VB < tim2VB) then
+ ! +
+ rate = float(itisva - tim1VB) / float(tim2VB - tim1VB)
+ do iv_glf = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+#if(LN)
+ alaiTV(i, j, iv_glf) = LAI1VB(i, j, iv_glf) + &
+ (LAI2VB(i, j, iv_glf) - LAI1VB(i, j, iv_glf)) * rate
+#endif
+ glf_TV(i, j, iv_glf) = glf1VB(i, j, iv_glf) + &
+ (glf2VB(i, j, iv_glf) - glf1VB(i, j, iv_glf)) * rate
+ enddo
+ enddo
+ enddo
+ ! +
+ newglfINI = 1
+ ! +
+ else
+ newglfINI = 0
+ endif
+ ! +
+ return
+endsubroutine INIglf
diff --git a/MAR/code_mar/inilbc.f90 b/MAR/code_mar/inilbc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..896ac3fd1ffcf50431a0ba83b3276951437bf9ed
--- /dev/null
+++ b/MAR/code_mar/inilbc.f90
@@ -0,0 +1,511 @@
+#include "MAR_pp.def"
+subroutine INIlbc(ihamr_lbc, nhamr_lbc, newlbc)
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT ATMOS Tue 27-10-2017 MAR |
+ ! | subroutine INIlbc initializes MAR Lateral Boundaries |
+ ! | verifies MARlbc.DAT EOF |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: ihamr_lbc : Time Digital Filter Status |
+ ! | ^^^^^ nhamr_lbc : Time Digital Filter Set Up |
+ ! | |
+ ! | OUTPUT: newlbc : (0,1) ==> (NO new LBC ,new LBC) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ vaxgLB,vaxdLB,vayiLB,vaysLB: Current LBCs |
+ ! | v1xgLB,v1xdLB,v1yiLB,v1ysLB: Previous Nesting Time Step LBCs |
+ ! | v2xgLB,v2xdLB,v2yiLB,v2ysLB: Next Nesting Time Step LBCs |
+ ! | tim1LB,tim2LB : LBC Nesting Times n, n+1 |
+ ! | |
+ ! | CAUTION: It is assumed that tim1LB and tim2LB do not change when the |
+ ! | ^^^^^^^^ Variables are reassigned after the dynamical Initialization |
+ ! | (Reassignation => itexpe:= nham => itimar:= itimar-nham*dt) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use marmagic
+ use marsnd
+#if(AO)
+ use mar_ao
+#endif
+
+ implicit none
+
+ integer i, j, k, m
+ integer ihamr_lbc, nhamr_lbc
+ integer newlbc
+ real pst__1, pst_mx
+ common / INIlbcRLoc / pst__1, pst_mx
+
+ ! +--Local Variables
+ ! + ================
+
+ integer(kind=8) itimar, iv_ilb
+ real rate, correction_humidity
+ real vax_An, vax_Ap, vax_A
+ real qsat0D, qs, tt
+#if(CE)
+ real qse_0D, qse
+#endif
+#if(FS)
+ ! rh_min : relative humidity above which clouds exist
+ real rh_min, qq
+ ! fac_qq : prescribed specific humidity tuning at LBC
+ real fac_qq
+ data rh_min/0.80/
+ ! fac_qq = 1.50 ==> 0.8 + 1.5 * 0.2 = 1.1
+ data fac_qq/1.50/
+#endif
+ ! +--Current Time
+ ! + ============
+
+ itimar = ou2sGE(iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, jsecGE)
+#if(HF)
+ itimar = +(ihamr_lbc + nhamr_lbc) * idt
+#endif
+
+ !XF
+ ! WARNING Compile with -i8 if the simulation run > 50yrs!!
+ !XF
+
+ ! initialize iSND jSND for PHYrad_top initialization
+ ! ==================================================
+ iSND = 1
+ jSND = 1
+
+ ! +--New LBC
+ ! + =======
+
+ if(itimar > tim2LB) then
+
+ tim1LB = tim2LB
+
+ write(6, 6001) jda_LB, labmGE(mma_LB), iyr_LB, &
+ jhu_LB, tim1LB, &
+ jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itimar
+6001 format(/, ' 1st LBC /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/', 2x, &
+ ' t =', i12, 's A.P.', &
+ /, ' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12)
+
+ if(jdh_LB == 0) jdh_LB = -1
+ open(unit=11, status='old', form='unformatted', file='MARlbc.DAT')
+ rewind 11
+11 continue
+ if(jdh_LB <= 0) go to 10
+
+ ! +--LBC at nesting time step n
+ ! + --------------------------
+
+ do iv_ilb = 1, 5
+ do i = 1, n7mxLB
+ do k = 1, mz
+ do j = 1, my
+ v1xgLB(i, j, k, iv_ilb) = v2xgLB(i, j, k, iv_ilb)
+ v2xgLB(i, j, k, iv_ilb) = 0.0
+ enddo
+ enddo
+ enddo
+
+ do i = mx - n6mxLB, mx
+ do k = 1, mz
+ do j = 1, my
+ v1xdLB(i, j, k, iv_ilb) = v2xdLB(i, j, k, iv_ilb)
+ v2xdLB(i, j, k, iv_ilb) = 0.0
+ enddo
+ enddo
+ enddo
+
+ do j = 1, n7myLB
+ do k = 1, mz
+ do i = 1, mx
+ v1yiLB(i, j, k, iv_ilb) = v2yiLB(i, j, k, iv_ilb)
+ v2yiLB(i, j, k, iv_ilb) = 0.0
+ enddo
+ enddo
+ enddo
+
+ do j = my - n6myLB, my
+ do k = 1, mz
+ do i = 1, mx
+ v1ysLB(i, j, k, iv_ilb) = v2ysLB(i, j, k, iv_ilb)
+ v2ysLB(i, j, k, iv_ilb) = 0.0
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ sst1LB(i, j) = sst2LB(i, j)
+ enddo
+ enddo
+
+ ! +--LBC at nesting time step n+1
+ ! + ----------------------------
+
+ read(11) iyr_LB, mma_LB, jda_LB, jhu_LB, jdh_LB
+ read(11) v2xgLB, v2xdLB, v2yiLB, v2ysLB
+ read(11) sst2LB
+
+ tim2LB = ou2sGE(iyr_LB, mma_LB, jda_LB, jhu_LB, 0, 0)
+
+ do iv_ilb = 1, 2
+ do i = 1, n7mxLB
+ do k = 1, mz
+ do j = 1, my
+ v2xgLB(i, j, k, iv_ilb) = v2xgLB(i, j, k, iv_ilb) / SFm_DY(i, j)
+ enddo
+ enddo
+ enddo
+
+ do i = mx - n6mxLB, mx
+ do k = 1, mz
+ do j = 1, my
+ v2xdLB(i, j, k, iv_ilb) = v2xdLB(i, j, k, iv_ilb) / SFm_DY(i, j)
+ enddo
+ enddo
+ enddo
+
+ do j = 1, n7myLB
+ do k = 1, mz
+ do i = 1, mx
+ v2yiLB(i, j, k, iv_ilb) = v2yiLB(i, j, k, iv_ilb) / SFm_DY(i, j)
+ enddo
+ enddo
+ enddo
+
+ do j = my - n6myLB, my
+ do k = 1, mz
+ do i = 1, mx
+ v2ysLB(i, j, k, iv_ilb) = v2ysLB(i, j, k, iv_ilb) / SFm_DY(i, j)
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ if(itimar > tim2LB) go to 11
+
+ write(6, 6002) jda_LB, labmGE(mma_LB), iyr_LB, &
+ jhu_LB, jdh_LB, tim2LB
+6002 format(' 2nd LBC /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/(', i1, &
+ ') t =', i12)
+
+10 continue
+ close(unit=11)
+
+ ! +--Force Sursaturation where relative humidity larger than rh_min (i.e., 80%)
+ ! + --------------------------------------------------------------------------
+
+ do i = 1, n7mxLB
+ do k = 1, mz
+ do j = 1, my
+ tt = v2xgLB(i, j, k, 4) &
+ * exp(cap * log(v2xgLB(i, j, 1, 5) * sigma(k) + ptopDY))
+ qs = qsat0D(tt, sigma(k), v2xgLB(i, j, 1, 5), ptopDY, 0)
+#if(FS)
+ qq = qs * rh_min
+#endif
+#if(CE)
+ qse = qse_0D(tt, sigma(k), v2xgLB(i, j, 1, 5), ptopDY)
+#endif
+#if(FS)
+ v2xgLB(i, j, k, 3) = min(v2xgLB(i, j, k, 3), qq) &
+ + fac_qq * max(v2xgLB(i, j, k, 3) - qq, 0.)
+#endif
+#if(CE)
+ v2xgLB(i, j, k, 3) = v2xgLB(i, j, k, 3) * qs / qse
+#endif
+
+ enddo
+ enddo
+ enddo
+
+ do i = mx - n6mxLB, mx
+ do k = 1, mz
+ do j = 1, my
+ tt = v2xdLB(i, j, k, 4) &
+ * exp(cap * log(v2xdLB(i, j, 1, 5) * sigma(k) + ptopDY))
+ qs = qsat0D(tt, sigma(k), v2xdLB(i, j, 1, 5), ptopDY, 0)
+#if(FS)
+ qq = qs * rh_min
+#endif
+#if(CE)
+ qse = qse_0D(tt, sigma(k), v2xdLB(i, j, 1, 5), ptopDY)
+#endif
+#if(FS)
+ v2xdLB(i, j, k, 3) = min(v2xdLB(i, j, k, 3), qq) &
+ + fac_qq * max(v2xdLB(i, j, k, 3) - qq, 0.)
+#endif
+#if(CE)
+ v2xdLB(i, j, k, 3) = v2xdLB(i, j, k, 3) * qs / qse
+#endif
+
+ enddo
+ enddo
+ enddo
+
+ do j = 1, n7myLB
+ do k = 1, mz
+ do i = 1, mx
+ tt = v2yiLB(i, j, k, 4) &
+ * exp(cap * log(v2yiLB(i, j, 1, 5) * sigma(k) + ptopDY))
+ qs = qsat0D(tt, sigma(k), v2yiLB(i, j, 1, 5), ptopDY, 0)
+#if(FS)
+ qq = qs * rh_min
+#endif
+#if(CE)
+ qse = qse_0D(tt, sigma(k), v2yiLB(i, j, 1, 5), ptopDY)
+#endif
+#if(FS)
+ v2yiLB(i, j, k, 3) = min(v2yiLB(i, j, k, 3), qq) &
+ + fac_qq * max(v2yiLB(i, j, k, 3) - qq, 0.)
+#endif
+#if(CE)
+ v2yiLB(i, j, k, 3) = v2yiLB(i, j, k, 3) * qs / qse
+#endif
+
+ enddo
+ enddo
+ enddo
+
+ do j = my - n6myLB, my
+ do k = 1, mz
+ do i = 1, mx
+ tt = v2ysLB(i, j, k, 4) &
+ * exp(cap * log(v2ysLB(i, j, 1, 5) * sigma(k) + ptopDY))
+ qs = qsat0D(tt, sigma(k), v2ysLB(i, j, 1, 5), ptopDY, 0)
+#if(FS)
+ qq = qs * rh_min
+#endif
+#if(CE)
+ qse = qse_0D(tt, sigma(k), v2ysLB(i, j, 1, 5), ptopDY)
+#endif
+#if(FS)
+ v2ysLB(i, j, k, 3) = min(v2ysLB(i, j, k, 3), qq) &
+ + fac_qq * max(v2ysLB(i, j, k, 3) - qq, 0.)
+#endif
+#if(CE)
+ v2ysLB(i, j, k, 3) = v2ysLB(i, j, k, 3) * qs / qse
+#endif
+
+ enddo
+ enddo
+ enddo
+
+ else
+#if(WR)
+ write(6, 6003) jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itimar
+6003 format(' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12, 's A.P.')
+#endif
+ endif
+
+ ! +--Time Interpolation
+ ! + ==================
+
+ if(itimar <= tim2LB .and. tim1LB < tim2LB) then
+
+ rate = float(itimar - tim1LB) / float(tim2LB - tim1LB)
+ do iv_ilb = 1, 5
+ do i = 1, n7mxLB
+ do k = 1, mz
+ do j = 1, my
+ vaxgLB(i, j, k, iv_ilb) = v1xgLB(i, j, k, iv_ilb) + &
+ (v2xgLB(i, j, k, iv_ilb) - v1xgLB(i, j, k, iv_ilb)) * rate
+
+ if(iv_ilb == 3 .and. correction_humidity_boundary /= 0.) &
+ vaxgLB(i, j, k, iv_ilb) = vaxgLB(i, j, k, iv_ilb) * (1.+ &
+ correction_humidity_boundary)
+
+ enddo
+ enddo
+ enddo
+
+ do i = mx - n6mxLB, mx
+ do k = 1, mz
+ do j = 1, my
+ vaxdLB(i, j, k, iv_ilb) = v1xdLB(i, j, k, iv_ilb) + &
+ (v2xdLB(i, j, k, iv_ilb) - v1xdLB(i, j, k, iv_ilb)) * rate
+
+ if(iv_ilb == 3 .and. correction_humidity_boundary /= 0.) &
+ vaxdLB(i, j, k, iv_ilb) = vaxdLB(i, j, k, iv_ilb) * (1.+ &
+ correction_humidity_boundary)
+
+ enddo
+ enddo
+ enddo
+
+ do j = 1, n7myLB
+ do k = 1, mz
+ do i = 1, mx
+ vayiLB(i, j, k, iv_ilb) = v1yiLB(i, j, k, iv_ilb) + &
+ (v2yiLB(i, j, k, iv_ilb) - v1yiLB(i, j, k, iv_ilb)) * rate
+
+ if(iv_ilb == 3 .and. correction_humidity_boundary /= 0.) &
+ vayiLB(i, j, k, iv_ilb) = vayiLB(i, j, k, iv_ilb) * (1.+ &
+ correction_humidity_boundary)
+
+ enddo
+ enddo
+ enddo
+
+ do j = my - n6myLB, my
+ do k = 1, mz
+ do i = 1, mx
+ vaysLB(i, j, k, iv_ilb) = v1ysLB(i, j, k, iv_ilb) + &
+ (v2ysLB(i, j, k, iv_ilb) - v1ysLB(i, j, k, iv_ilb)) * rate
+
+ if(iv_ilb == 3 .and. correction_humidity_boundary /= 0.) &
+ vaysLB(i, j, k, iv_ilb) = vaysLB(i, j, k, iv_ilb) * (1.+ &
+ correction_humidity_boundary)
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! +--Zonally Averaged Version
+ ! + ------------------------
+
+ if(mmy == 1) then
+ if(itexpe == 1) then
+ pst__1 = vaxgLB(1, 1, 1, 5)
+ pst_mx = vaxdLB(mx, 1, 1, 5)
+ endif
+#if(IN)
+ ! +--LBC: Smooth Set up of the Large Scale Wind
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(itexpe * dt < 86400.) then
+ rate = itexpe * dt / 86400.
+ do iv_ilb = 1, 2
+ do i = 1, n7mxLB
+ do k = 1, mz
+ do j = 1, my
+ vaxgLB(i, j, k, iv_ilb) = vaxgLB(i, j, k, iv_ilb) * rate
+ enddo
+ enddo
+ enddo
+ do i = mx - n6mxLB, mx
+ do k = 1, mz
+ do j = 1, my
+ vaxdLB(i, j, k, iv_ilb) = vaxdLB(i, j, k, iv_ilb) * rate
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+ ! +--Meridional Wind: zero Mass Flux Correction, excedent Mass Flux Reduction
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ iv_ilb = 2
+ j = 1
+ do i = 1, n7mxLB
+ vax_An = 0.
+ vax_Ap = 0.
+ do k = 1, mz
+ vax_An = vax_An + min(real(vaxgLB(i, j, k, iv_ilb)), 0.) &
+ * dsigm1(k)
+ vax_Ap = vax_Ap + max(real(vaxgLB(i, j, k, iv_ilb)), 0.) &
+ * dsigm1(k)
+ enddo
+ vax_A = vax_An + vax_Ap
+ if(vax_A > 0.) then
+ vax_A = (vax_Ap - vax_A) / max(epsi, vax_Ap)
+ do k = 1, mz
+ if(vaxgLB(i, j, k, iv_ilb) > 0.) &
+ vaxgLB(i, j, k, iv_ilb) = vaxgLB(i, j, k, iv_ilb) * vax_A
+ enddo
+ else
+ vax_A = (vax_An - vax_A) / min(-epsi, vax_An)
+ do k = 1, mz
+ if(vaxgLB(i, j, k, iv_ilb) < 0.) &
+ vaxgLB(i, j, k, iv_ilb) = vaxgLB(i, j, k, iv_ilb) * vax_A
+ enddo
+ endif
+ enddo
+
+ do i = mx - n6mxLB, mx
+ vax_An = 0.
+ vax_Ap = 0.
+ do k = 1, mz
+ vax_An = vax_An + min(real(vaxdLB(i, j, k, iv_ilb)), 0.) &
+ * dsigm1(k)
+ vax_Ap = vax_Ap + max(real(vaxdLB(i, j, k, iv_ilb)), 0.) &
+ * dsigm1(k)
+ enddo
+ vax_A = vax_An + vax_Ap
+ if(vax_A > 0.) then
+ vax_A = (vax_Ap - vax_A) / max(epsi, vax_Ap)
+ do k = 1, mz
+ if(vaxdLB(i, j, k, iv_ilb) > 0.) &
+ vaxdLB(i, j, k, iv_ilb) = vaxdLB(i, j, k, iv_ilb) * vax_A
+ enddo
+ else
+ vax_A = (vax_An - vax_A) / min(-epsi, vax_An)
+ do k = 1, mz
+ if(vaxdLB(i, j, k, iv_ilb) < 0.) &
+ vaxdLB(i, j, k, iv_ilb) = vaxdLB(i, j, k, iv_ilb) * vax_A
+ enddo
+ endif
+ enddo
+
+ ! +--Surface Pressure: no Mass Variation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do i = 1, n7mxLB
+ vaxgLB(i, 1, 1, 5) = pst__1 ! [kPa]
+ enddo
+ do i = mx - n6mxLB, mx
+ vaxdLB(i, 1, 1, 5) = pst_mx ! [kPa]
+ enddo
+ endif
+
+ ! +--Sea Surface Temperatures
+ ! + ------------------------
+
+ do j = 1, my
+ do i = 1, mx
+
+ !Coupling: inside NEMO domaine sst_LB changed in
+ ! - inigen.f (first timpe step)
+ ! -oasis_2_mar.f (all the others)
+ ! outside MAJ sst_LB here with the usual sst rate
+ ! CK_AO 28/02/2020
+
+ !old way
+ !c #AO sst1LB(i,j) =sst_LB(i,j)
+ !c #AO sst2LB(i,j) =sst_LB(i,j)
+
+ sst_LB(i, j) = sst1LB(i, j) + &
+ (sst2LB(i, j) - sst1LB(i, j)) * rate
+#if(AO)
+ if(weightao_sst(i, j) /= 1) then
+ sst_LB(i, j) = (1.-weightao_sst(i, j)) * srftAO(i, j, 1) + &
+ (weightAO_sst(i, j) * sst_LB(i, j))
+ endif
+#endif
+ enddo
+ enddo
+
+ newlbc = 1
+
+ else
+ newlbc = 0
+ endif
+
+ return
+end
diff --git a/MAR/code_mar/iniphy.f90 b/MAR/code_mar/iniphy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..16ba2223aeee802a7ada64d3b31bdc4f3adf4afb
--- /dev/null
+++ b/MAR/code_mar/iniphy.f90
@@ -0,0 +1,287 @@
+#include "MAR_pp.def"
+subroutine iniphy
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT ATMOS Thu 21-Jul-2011 MAR |
+ ! | subroutine iniphy Initializes coupling Variables between |
+ ! | MAR Surface and Atmosphere |
+ ! | Calls MAR Surface Model initializing Routines|
+ ! | Initializes MAR Cloud Microphysical Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: itexpe: Experiment Iteration Counter |
+ ! | ^^^^^ micphy: Cloud Microphysics Switch |
+ ! | fxlead: Lead (in Sea ice) Fraction |
+ ! | polmod: Polynya Model Switch |
+ ! | snomod: Snow Model Switch |
+ ! | reaVAR: Previous OR Large Scale Variables Switch |
+ ! | reaLBC: LBC: Large Scale Variables Switch |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ pstDY (mx,my) : Atmosphere Thickness [kPa] |
+ ! | (itexpe=0): TairSL(mx,my) : Surface Air Temperature [K] |
+ ! | (Sounding Extrapolated to the Surface |
+ ! | - dtagSL )|
+ ! | (itexpe=1): pktaDY(mx,my,mzz): Reduced Potential Temperature |
+ ! | sh (mx,my) : Surface Elevation [m] |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ tsrfSL(mx,my,mw) : Surface Temperature [K] |
+ ! | (itexpe=1): TairSL(mx,my) : Surface Air Temperature [K] |
+ ! | (CAUTION: CRUDE REINITIALISATION |
+ ! | BE CAREFULL WHEN USING PRESCRIBED TEMPERATURE) |
+ ! | SLsrfl(mx,my,mw) : Surface Type Area |
+ ! | (itexpe=0): pktaDY(mx,my,mzz): Reduced Potential Temperature |
+ ! | gplvDY(mx,my,mzz): Geopotential [m2/s2] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_lb
+ use mar_hy
+ use mar_ca
+ use mar_sl
+ use mar_sv
+ use mar_tv
+#if(AO)
+ include 'MAR_AO.inc'
+#endif
+#if(BS)
+ include 'MAR_BS.inc'
+#endif
+#if(iso)
+ use mariso, only: qiHY_iso, qsHY_iso, qwHY_iso, qrHY_iso, &
+ rainHY_iso, snowHY_iso, crysHY_iso, rainCA_iso, snowCA_iso
+#endif
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m, n
+ real tsrf, rowat2
+
+ ! +--First Guess Initialization
+ ! + ==========================
+ if(.not. reaVAR) then
+ ! +--Surface Geopotential
+ ! + --------------------
+ do j = 1, my
+ do i = 1, mx
+ gplvDY(i, j, mzz) = sh(i, j) * gravit
+ enddo
+ enddo
+ ! +--Grid BOXES Area (First Guess)
+ ! + -----------------------------
+ do j = 1, my
+ do i = 1, mx
+ SLsrfl(i, j, 1) = 1.0
+ SLsrfl(i, j, 2) = 0.0
+ enddo
+ enddo
+ ! +--Surface Temperature (First Guess)
+ ! + ---------------------------------
+ do n = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ tsrfSL(i, j, n) = TairSL(i, j)
+ enddo
+ enddo
+ enddo
+ do j = 1, my
+ do i = 1, mx
+ go to(101, 102, 103, 104, 105) isolSL(i, j)
+101 continue
+ if(reaLBC) then
+ tsrfSL(i, j, 1) = sst_LB(i, j)
+ else
+ tsrfSL(i, j, 1) = max(sst_SL, tfrwat)
+ endif
+ go to 106
+102 continue
+#if(OM)
+ tsrf = tsrfSL(i, j, 1)
+#endif
+ tsrfSL(i, j, 1) = min(tsrfSL(i, j, 1), TfSnow)
+#if(OM)
+ tsrfSL(i, j, 1) = tsrf
+#endif
+ tsrfSL(i, j, 2) = sst_SL
+ go to 106
+103 continue
+ tsrfSL(i, j, 1) = min(tsrfSL(i, j, 1), TfSnow)
+ go to 106
+104 continue
+ go to 106
+105 continue
+ go to 106
+106 continue
+ enddo
+ enddo
+ endif
+
+#if(PO)
+ ! +--Polynya Model
+ ! + =============
+ ! +--Polynya Model Initialisation
+ ! + ----------------------------
+ ! cCA : SRFini_pol not found
+ ! ! + **********
+ ! call SRFini_pol
+ ! ! + **********
+#endif
+
+ ! +--Snow Model
+ ! + ==========
+ ! cCAiso : ro_SL is not used, replaced with sisvat variables
+ rowat2 = ro_Wat**1.88
+ do j = 1, my
+ do i = 1, mx
+ ro_SL0(i, j) = (d1_SL(i, j) / sqrt(csnow * cdice * cs2SL / rowat2))**(1.0 / 1.44)
+ ro_SL(i, j) = ro_SL0(i, j)
+ ! SaltSL: Here an impossible Value
+ ! (Preclude Saltation)
+ SaltSL(i, j) = 1.e2
+ enddo
+ enddo
+
+ if(.not. snomod) then
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) >= 2 .and. tsrfSL(i, j, 1) < TfSnow) then
+ ro_SL(i, j) = 0.00
+ ! SaltSL: Threshold Friction Velocity for Blowing Snow
+ ! (Budd et al., 1966, Byrd Snow Project)
+ SaltSL(i, j) = 0.38
+ endif
+ enddo
+ enddo
+ endif
+
+ ! +--Soil Model
+ ! + ==========
+ do j = 1, my
+ do i = 1, mx
+ roseSL(i, j) = 0.0
+ hmelSL(i, j) = 0.0
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ go to(51, 51, 53, 54, 51) isolSL(i, j)
+51 continue
+ t2_SL(i, j) = tsrfSL(i, j, 1)
+ go to 59
+53 continue
+ if(.not. snomod) then
+ t2_SL(i, j) = tsrfSL(i, j, 1)
+ endif
+ go to 59
+54 continue
+ t2_SL(i, j) = tsrfSL(i, j, 1)
+ w2_SL(i, j) = w20SL
+ wg_SL(i, j) = wg0SL
+ wk_SL(i, j) = wk0SL
+ wx_SL(i, j) = wx0SL
+ go to 59
+59 continue
+ enddo
+ enddo
+
+ ! +--Grid BOXES Area (Update)
+ ! + ========================
+ if(VSISVAT) then
+ do j = 1, my
+ do i = 1, mx
+ nSLsrf(i, j) = nvx
+ enddo
+ enddo
+ do n = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+ SLsrfl(i, j, n) = ifraTV(i, j, n)
+ SLsrfl(i, j, n) = SLsrfl(i, j, n) * 0.01
+ enddo
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) <= 4) then
+ nSLsrf(i, j) = max(iun, nSLsrf(i, j))
+ SLsrfl(i, j, 1) = 1.-SLsrfl(i, j, 2)
+ else
+ nSLsrf(i, j) = 1
+ SLsrfl(i, j, 1) = 1.
+ nSLsrf(i, j) = nvx
+ do n = 1, nvx
+ SLsrfl(i, j, n) = ifraTV(i, j, n)
+ SLsrfl(i, j, n) = SLsrfl(i, j, n) * 0.01
+ enddo
+ endif
+ enddo
+ enddo
+ endif
+
+ ! +--Surface Temperature (Update)
+ ! + ============================
+ do j = 1, my
+ do i = 1, mx
+ TairSL(i, j) = 0.
+ do n = 1, mw
+ TairSL(i, j) = TairSL(i, j) + SLsrfl(i, j, n) * tsrfSL(i, j, n)
+ enddo
+ pktaDY(i, j, mzz) = TairSL(i, j) / ((pstDY(i, j) + ptopDY)**cap)
+ enddo
+ enddo
+
+ ! +--Microphysics
+ ! + ============
+
+ if(micphy) then
+ turnHY = .false.
+ qiHY = 0.0
+ qsHY = 0.0
+ qwHY = 0.0
+ qrHY = 0.0
+#if(iso)
+ qiHY_iso = 0.0
+ qsHY_iso = 0.0
+ qwHY_iso = 0.0
+ qrHY_iso = 0.0
+#endif
+ hlatHY = 0.0
+ snfHY = 0.0
+ depHY = 0.0
+ sblHY = 0.0
+ rnfHY = 0.0
+ evpHY = 0.0
+ smtHY = 0.0
+ qssblHY = 0.0
+#if(iso)
+ ! todo : check if snfHY, sblHY, rnfHY, evpHY needed with isotopes
+ ! todo : check if snf2D, sbl2D, rnf2D, evp2D needed with isotopes
+#endif
+#if(qg)
+ qgHY = 0.0
+#endif
+ rainHY = 0.0
+ snowHY = 0.0
+ crysHY = 0.0
+ rainCA = 0.0
+ snowCA = 0.0
+#if(iso)
+ rainHY_iso = 0.0
+ snowHY_iso = 0.0
+ crysHY_iso = 0.0
+ rainCA_iso = 0.0
+ snowCA_iso = 0.0
+#endif
+ endif
+
+ return
+endsubroutine iniphy
diff --git a/MAR/code_mar/inisic.f90 b/MAR/code_mar/inisic.f90
new file mode 100644
index 0000000000000000000000000000000000000000..045dfec6094a8313a25bc6b5c647b7872a3a65ec
--- /dev/null
+++ b/MAR/code_mar/inisic.f90
@@ -0,0 +1,176 @@
+#include "MAR_pp.def"
+subroutine INIsic(ihamr_sic, nhamr_sic, newsicINI)
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT Sea-Ice 03-03-2004 MAR |
+ ! | subroutine INIsic is used to initialize MAR Sea-Ice Fractions |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: ihamr_sic: Time Digital Filter Status |
+ ! | ^^^^^ nhamr_sic: Time Digital Filter Set Up |
+ ! | |
+ ! | OUTPUT: newsicINI: (0,1) ==> (NO new sic , new sic) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | OUTPUT: sicsIB: Current Sea-Ice Fraction |
+ ! | ^^^^^^^ sic1sI: Previous Nesting Time Step Sea-Ice Fraction |
+ ! | sic2sI: Next Nesting Time Step Sea-Ice Fraction |
+ ! | tim1sI,tim2sI: Times n, n+1 of Sea-Ice Fraction |
+ ! | |
+ ! | CAUTION: It is assumed that tim1sI and tim2sI do not change when the |
+ ! | ^^^^^^^^ Variables are reassigned after the dynamical Initialization |
+ ! | (Reassignation => itexpe := nham => timar := timar-nham*dt) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_sl
+ use mar_sv
+ use mar_TV
+ use marsib
+#if(AO)
+ use mar_ao
+#endif
+
+ implicit none
+
+ integer ihamr_sic, nhamr_sic
+ integer newsicINI
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ !XF
+ integer(kind=8) itisIB
+ real rate
+
+ ! +--Current Time
+ ! + ============
+
+ itisIB = ou2sGE(iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, jsecGE)
+#if(HF)
+ itisIB = itisIB + (ihamr_sic + nhamr_sic) * idt
+#endif
+
+ ! +--Reinitialization of the Sea-Ice Fraction
+ ! + ----------------------------------------
+
+ if(iterun == 0) then
+ jdh_sI = 1
+ iyr_sI = iyrrGE
+ mma_sI = mmarGE
+ jda_sI = jdarGE
+ jhu_sI = jhurGE
+ tim1sI = itisIB
+ tim2sI = itisIB
+ do j = 1, my
+ do i = 1, mx
+ sic1sI(i, j) = sicsIB(i, j)
+ sic2sI(i, j) = sicsIB(i, j)
+ enddo
+ enddo
+
+ endif
+
+ ! +--New sIB
+ ! + =======
+
+ if(itisIB > tim2sI) then
+
+ tim1sI = tim2sI
+
+ write(6, 6001) jda_sI, labmGE(mma_sI), iyr_sI, &
+ jhu_sI, tim1sI, &
+ jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itisIB
+6001 format(/, ' 1st sIB /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/', 2x, &
+ ' t =', i12, 's A.P.', &
+ /, ' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12)
+ ! +
+ if(jdh_sI == 0) jdh_sI = -1
+ open(unit=11, status='old', form='unformatted', file='MARsic.DAT')
+ rewind 11
+11 continue
+ if(jdh_sI <= 0) go to 10
+
+ ! +--sIB at nesting time step n
+ ! + --------------------------
+
+ do j = 1, my
+ do i = 1, mx
+ sic1sI(i, j) = sic2sI(i, j)
+ sic2sI(i, j) = 0.d0
+ enddo
+ enddo
+
+ ! +--sIB at nesting time step n+1
+ ! + ----------------------------
+
+ read(11) iyr_sI, mma_sI, jda_sI, jhu_sI, jdh_sI
+ read(11) sic2sI
+
+ tim2sI = ou2sGE(iyr_sI, mma_sI, jda_sI, jhu_sI, 0, 0)
+
+ if(itisIB > tim2sI) go to 11
+
+ write(6, 6002) jda_sI, labmGE(mma_sI), iyr_sI, &
+ jhu_sI, jdh_sI, tim2sI
+6002 format(' 2nd sIB /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/(', i1, &
+ ') t =', i12)
+
+10 continue
+ close(unit=11)
+
+ else
+#if(WR)
+ write(6, 6003) jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itisIB
+6003 format(' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12, 's A.P.')
+#endif
+ endif
+
+ ! +--Time Interpolation
+ ! + ==================
+
+ if(itisIB <= tim2sI .and. tim1sI < tim2sI) then
+
+ rate = float(itisIB - tim1sI) / float(tim2sI - tim1sI)
+ do j = 1, my
+ do i = 1, mx
+ !Coupling: inside NEMO domaine sicsIB changed in
+ ! - inigen.f (first timpe step)
+ ! -oasis_2_mar.f (all the others)
+ ! outside MAJ sicsIB here with the usual sic rate
+ ! CK_AO 28/02/2020
+
+ ! old way
+ !c #AO sic1sI(i,j)=sicsIB(i,j)
+ !c #AO sic2sI(i,j)=sicsIB(i,j)
+
+ sicsIB(i, j) = sic1sI(i, j) + &
+ (sic2sI(i, j) - sic1sI(i, j)) * rate
+
+#if(AO)
+ if(weightAO_sic(i, j) /= 1) then
+ sicsIB(i, j) = (1.-weightao_sic(i, j)) * sicsAO(i, j) + &
+ (weightAO_sic(i, j) * sicsIB(i, j))
+ endif
+#endif
+ enddo
+ enddo
+
+ newsicINI = 1
+
+ else
+ newsicINI = 0
+ endif
+
+ return
+endsubroutine INIsic
diff --git a/MAR/code_mar/inisnd.f90 b/MAR/code_mar/inisnd.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c4be764952b222b381161f3dd4ffdc7247fb01c0
--- /dev/null
+++ b/MAR/code_mar/inisnd.f90
@@ -0,0 +1,1560 @@
+#include "MAR_pp.def"
+subroutine inisnd
+ ! +-----------------------------------------------------------------------+
+ ! | MAR INPUT ATMOS 19-02-2004 MAR |
+ ! | subroutine inisnd includes Large Scale Conditions from a Sounding |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^^ itexpe: Experiment Iteration Index |
+ ! | iterun: Run Iteration Index (n Run for 1 Experiment) |
+ ! | log_1D=(0,1) (before,after) Boundary Layer Initialization |
+ ! | potvor:"Potential Vorticity conserved" Initialization Switch |
+ ! | potvor=.T. => Potential Vorticity (PV) Conservation |
+ ! | Constraint is used (in 2-D Mode only) |
+ ! | conmas:"Mass conserved" Initialization Switch |
+ ! | conmas=.T. => Mass Conservation is used |
+ ! | |
+ ! | INPUT: Sounding(s) / File MARSND.dat |
+ ! | ^^^^^^ |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ MESOSCALE VARIABLES |
+ ! | ^^^^^^^^^^^^^^^^^^^ |
+ ! | nSND : Sounding Number |
+ ! | pstDY (mx,my) : Initial Model Thickness [kPa] |
+ ! | pstDY1(mx,my) : Initial Model Thickness -FIXED- [kPa] |
+ ! | ugeoDY(mx,my,mz) : Initial Geo. Wind (x-Direction) [m/s] |
+ ! | vgeoDY(mx,my,mz) : Initial Geo. Wind (y-Direction) [m/s] |
+ ! | uairDY(mx,my,mz) : Initial Wind (x-Direction) [m/s] |
+ ! | vairDY(mx,my,mz) : Initial Wind (y-Direction) [m/s] |
+ ! | tairDY(mx,my,mz) : Initial Temperature [K] |
+ ! | TairSL(mx,my) : Initial Surface Air Temperature [K] |
+ ! | (Sounding Extrapolated to the Surface; |
+ ! | - dtagSL ) |
+ ! | pktaDY(mx,my,mzz): Initial Reduced Potential Temperature |
+ ! | qvDY(mx,my,mz) : Initial Specific Humididity [kg/kg] |
+ ! | qvapSL(mx,my) : Initial Specific Humididity [kg/kg] |
+ ! | (Sounding Extrapolated to the Surface) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ LARGE SCALE VARIABLES (BOUNDARIES and DOMAIN AVERAGE) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! | 1. LBC |
+ ! | vaxgLB (mx,my,mz,n):Large Scale Values of the Variables |
+ ! | (n=1,2,3,4,5) <=> (u,v,qv,pktaDY,pstDY), |
+ ! | for x << |
+ ! | vaxdLB : idem, x >> |
+ ! | vayiLB : idem, y << |
+ ! | vaysLB : idem, y >> |
+ ! | zetaD : Potential Vorticity (CAUTION: Time Independant) |
+ ! | 2. UBC |
+ ! | uairUB, vairUB, pktaUB |
+ ! | |
+ ! | METHOD: Vertical Interpolation on Sigma Levels is first performed |
+ ! | ^^^^^^^ For two Soundings nearest in Time (before and after runtime) |
+ ! | Then Time Interpolation |
+ ! | This order was preferred to the reverse because it allows |
+ ! | to use Soundings having a different vertical Discretization |
+ ! | |
+ ! | # OPTIONS: _SC Supersaturation not allowed (do NOT USE for SCu cloud) |
+ ! | # ^^^^^^^^ #WR Additional Output |
+ ! | |
+ ! | CAUTION: inisnd may be used only for Large Scale Thermodynamics |
+ ! | ^^^^^^^^ independant of x and y (i.e.for not too large model domain) |
+ ! | zeSND fixed at its initial value whenever Sounding varies |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use marsnd
+ use mar_dy
+ use mar_lb
+ use mar_ub
+ use mar_sl
+ use mar_wk
+ use mar_io
+#if(NH)
+ use mar_nh
+#endif
+#if(PV)
+ use mar_PV
+#endif
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ===============
+#if(CS)
+ logical consnd
+#endif
+ integer i, j, k, m
+ integer logcon
+ integer lbcfix, lsf, lvg
+ integer intpol, jhsnd1, jhsnd2, i0snd, j0snd, ksnd, msnd
+ integer ishmin, jshmin, ii, jj, inew, jnew
+ integer iyrnew, mmanew, jdanew, jhunew
+ real tsurf0, qsurf0, gradti, graddt, gra, timar, timarn, timmar
+ real shmin, distmn, distij, ta_inv, pksh, gsnd, ddnew
+ real zetaD, dul, ttij_1, ttij_2
+ real qsat0D, acap, dem1
+
+ real pksnd(0:40, 2)
+ ! +... pksnd: pSND ** (R/Cp),
+ ! + where (pSND/100) ** (R/Cp) : Exner Function
+
+ real tmsnd(0:40, 2)
+ ! +... tmsnd: Potential Temperature
+ ! + averaged over the layer between ksnd-1/2 and ksnd+1/2
+
+ real pint(2)
+ real tint(2), qint(2)
+
+ real ttij(mz, 2), qvij(mz, 2)
+ real ulij(mz, 2), vlij(mz, 2)
+
+ real dpt(mz), dqa(mz)
+ real dug(mz), dvg(mz)
+
+ real fftt(3), ddtt(3)
+
+ ! +--DATA
+ ! + ====
+
+ data lbcfix/1/
+#if(CS)
+ data consnd/.true./
+#endif
+
+ data dem1/1.0e-1/
+
+ data lsf/0/
+#if(OB)
+ openLB = .true.
+ lbcfix = 0
+#endif
+
+ lvg = 0
+ ! +...lvg: is set to 1 if |Vg(sounding)| .ne. 0 anywhere
+
+ acap = 1.0 / cap
+ ! +...acap: Inverse of R / Cp
+
+ ttij_1 = 0.0
+ ttij_2 = 0.0
+
+ ! +--Time Parameters
+ ! + ===============
+
+ if(iterun == 0) then
+ tiSND1 = -99999999.99
+ tiSND2 = -99999999.99
+ iSND = imez
+ jSND = jmez
+ loSND = 1
+ endif
+
+ timar = ((iyrrGE * 365 + iyrrGE * 0.25 &
+ + njyrGE(mmarGE) + jdarGE) * 24 &
+ + jhurGE + itizGE(iSND, jSND)) * 36.d2 &
+ + minuGE * 6.d1 + jsecGE
+ timarn = timar
+
+ ! +--Interpolation Parameter
+ ! + =======================
+
+ if(tiSND1 >= tiSND2) &
+ intpol = 0
+ ! +... intpol = 0 ==> No Interpolation between two soundings
+ ! + 1 ==> Interpolation between two soundings
+
+ ! + +++++++++++++++++++++++++++++++
+ ! +--Search of the relevant Sounding
+ ! + +++++++++++++++++++++++++++++++
+
+ ! +--Main Dependant Variables
+ ! + ========================
+
+ tSND(:, 1) = (/277.0, 272.2, 268.7, 265.2, 261.7, &
+ 255.7, 249.7, 243.7, 237.7, 231.7, &
+ 225.7, 219.7, 219.2, 218.7, 218.2, &
+ 217.7, 217.2, 216.7, 216.2, 215.7, &
+ 215.2, 215.2, 215.2, 215.2, 215.2, &
+ 215.2, 215.2, 217.4, 227.8, 243.2, &
+ 258.5, 265.7, 265.7, 265.7, 265.7, &
+ 265.7, 265.7, 265.7, 265.7, 265.7, 265.7/)
+ tSND(:, 2) = (/277.0, 272.2, 268.7, 265.2, 261.7, &
+ 255.7, 249.7, 243.7, 237.7, 231.7, &
+ 225.7, 219.7, 219.2, 218.7, 218.2, &
+ 217.7, 217.2, 216.7, 216.2, 215.7, &
+ 215.2, 215.2, 215.2, 215.2, 215.2, &
+ 215.2, 215.2, 217.4, 227.8, 243.2, &
+ 258.5, 265.7, 265.7, 265.7, 265.7, &
+ 265.7, 265.7, 265.7, 265.7, 265.7, 265.7/)
+
+ qSND(:, 1) = (/27e-2, .27e-2, .21e-2, .17e-2, .13e-2, &
+ .80e-3, .51e-3, 32e-3, .14e-3, .67e-4, &
+ .35e-4, .18e-4, .20e-4, .20e-4, 70e-5, &
+ .45e-5, .40e-5, .39e-5, .40e-5, .42e-5, &
+ .48e-5, 51e-5, .68e-5, .81e-5, .10e-4, &
+ .13e-4, .17e-4, .20e-4, 14e-4, .10e-4, &
+ .14e-4, .69e-5, .70e-5, .72e-5, .74e-5, &
+ 75e-5, .77e-5, .79e-5, .81e-5, .83e-5, .86e-5/)
+ qSND(:, 2) = (/27e-2, .27e-2, .21e-2, .17e-2, .13e-2, &
+ .80e-3, .51e-3, 32e-3, .14e-3, .67e-4, &
+ .35e-4, .18e-4, .20e-4, .20e-4, 70e-5, &
+ .45e-5, .40e-5, .39e-5, .40e-5, .42e-5, &
+ .48e-5, 51e-5, .68e-5, .81e-5, .10e-4, &
+ .13e-4, .17e-4, .20e-4, 14e-4, .10e-4, &
+ .14e-4, .69e-5, .70e-5, .72e-5, .74e-5, &
+ 75e-5, .77e-5, .79e-5, .81e-5, .83e-5, .86e-5/)
+
+ zSND(:, 1) = (/-143., 0., 1001., 1993., 2992., &
+ 3993., 4994., 5983., 6978., 7988., &
+ 8984., 9970., 10968., 11975., 12966., &
+ 13949., 14945., 15932., 16950., 17900., &
+ 18914., 19884., 20894., 21933., 22985., &
+ 23799., 24990., 29928., 35068., 38589., &
+ 46673., 49408., 49583., 49761., 49948., &
+ 50132., 50324., 50521., 50723., 50930., 51143./)
+ zSND(:, 2) = (/-143., 0., 1001., 1993., 2992., &
+ 3993., 4994., 5983., 6978., 7988., &
+ 8984., 9970., 10968., 11975., 12966., &
+ 13949., 14945., 15932., 16950., 17900., &
+ 18914., 19884., 20894., 21933., 22985., &
+ 23799., 24990., 29928., 35068., 38589., &
+ 46673., 49408., 49583., 49761., 49948., &
+ 50132., 50324., 50521., 50723., 50930., 51143./)
+
+ pSND(:, 1) = (/1036., 1018., 897., 790., 694., &
+ 608., 531., 463., 402., 347., &
+ 299., 257., 220., 188., 161., &
+ 138., 118., 101., 86., 74., &
+ 63., 54., 46., 39., 33., &
+ 29., 24., 11., 5., 3., &
+ 1., 0.7, 0.685, 0.669, 0.654, &
+ 0.637, 0.622, 0.606, 0.591, 0.576, 0.560/)
+ pSND(:, 2) = (/1036., 1018., 897., 790., 694., &
+ 608., 531., 463., 402., 347., &
+ 299., 257., 220., 188., 161., &
+ 138., 118., 101., 86., 74., &
+ 63., 54., 46., 39., 33., &
+ 29., 24., 11., 5., 3., &
+ 1., 0.7, 0.685, 0.669, 0.654, &
+ 0.637, 0.622, 0.606, 0.591, 0.576, 0.560/)
+
+ ! + ------------------------------------
+ if(timar > tiSND2 .and. loSND == 1) then
+ ! + ------------------------------------
+
+ open(unit=2, status='old', file='MARsnd.dat')
+ rewind 2
+ read(2, 202) iyrSND, mmaSND, jdaSND, jhuSND
+202 format(4i4, f4.0)
+ read(2, 203)
+203 format(1x)
+ read(2, 202) iSND, jSND
+ read(2, 203)
+ read(2, 203)
+ read(2, 204)(tSND(ksnd, 1), qSND(ksnd, 1), &
+ zSND(ksnd, 1), pSND(ksnd, 1), &
+ fSND(ksnd, 1), dSND(ksnd, 1), ksnd=40, 0, -1)
+204 format((6d13.6))
+ read(2, 204) zeSND(1)
+ read(2, 202) loSND
+
+ ! +- Time Parameters
+ ! + ~~~~~~~~~~~~~~~
+ jhsnd1 = (iyrSND * 365 + iyrSND / 4 &
+ + njyrGE(mmaSND) + jdaSND) * 24 + jhuSND + itizGE(iSND, jSND)
+ tiSND1 = ((iyrSND * 365 + iyrSND / 4 &
+ + njyrGE(mmaSND) + jdaSND) * 24 + jhuSND + itizGE(iSND, jSND)) &
+ * 3.6d3
+
+ ! + ~~~~~~~~~
+ ! +- - -do until
+ msnd = 1
+200 continue
+ ! + ~~~~~~~~~
+
+ if(timar > tiSND1 .and. loSND == 1) then
+ msnd = msnd + 1
+ intpol = 1
+
+ read(2, 202) iyrnew, mmanew, jdanew, jhunew
+ read(2, 203)
+ read(2, 202) inew, jnew
+ read(2, 203)
+ read(2, 203)
+ read(2, 204)(tSND(ksnd, 2), qSND(ksnd, 2), &
+ zSND(ksnd, 2), pSND(ksnd, 2), &
+ fSND(ksnd, 2), dSND(ksnd, 2), ksnd=40, 0, -1)
+ read(2, 204) zeSND(2)
+ read(2, 202) loSND
+
+ if(abs(zeSND(2) - zeSND(1)) > epsi) &
+ write(6, 1)
+1 format(' **********************************', &
+ '**********************************', &
+ /, ' * CAUTION: zeSND is Time Dependant', &
+ ' (NOT taken into account in MAR) *', &
+ /, ' **********************************', &
+ '**********************************', /, 1x)
+
+ ! +- Time Parameters
+ ! + ~~~~~~~~~~~~~~~
+ jhsnd2 = (iyrnew * 365 + iyrnew / 4 &
+ + njyrGE(mmanew) + jdanew) * 24 + jhunew + itizGE(iSND, jSND)
+ tiSND2 = ((iyrnew * 365 + iyrnew / 4 &
+ + njyrGE(mmanew) + jdanew) * 24 + jhunew + itizGE(iSND, jSND)) &
+ * 3.6d3
+
+ ! +- Change of Year
+ ! + ~~~~~~~~~~~~~~~
+ timarn = timar
+ if(mmaSND == 12 .and. mmanew == 1) then
+#if(YR)
+ ! Change in case of iyrSND and iyrnew not defined (#YR)
+ jhsnd2 = jhsnd2 + nhyrGE
+ tiSND2 = tiSND2 + nhyrGE * 3600.0
+#endif
+
+ if(mmarGE == 1) &
+ timarn = timar + nhyrGE * 3600.0
+ endif
+
+ ! +- Constant Sounding if either imposed (logcon = 1) or MARsnd.dat at EOF
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ logcon = 0
+#if(CS)
+ if(itexpe == 0 .and. consnd) logcon = 1
+#endif
+ if(timarn > tiSND2 .or. logcon == 1) then
+
+ intpol = 0
+
+ jhsnd1 = jhsnd2
+ tiSND1 = tiSND2
+ iyrSND = iyrnew
+ mmaSND = mmanew
+ jdaSND = jdanew
+ jhuSND = jhunew
+ do ksnd = 0, 40
+ tSND(ksnd, 1) = tSND(ksnd, 2)
+ qSND(ksnd, 1) = qSND(ksnd, 2)
+ zSND(ksnd, 1) = zSND(ksnd, 2)
+ pSND(ksnd, 1) = pSND(ksnd, 2)
+ fSND(ksnd, 1) = fSND(ksnd, 2)
+ dSND(ksnd, 1) = dSND(ksnd, 2)
+ enddo
+ endif
+
+ else
+
+ ! +- Constant Sounding if Simulation starts before 1st Sounding Time
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ intpol = 0
+
+ jhsnd2 = jhsnd1
+ tiSND2 = tiSND1
+ iyrnew = iyrSND
+ mmanew = mmaSND
+ jdanew = jdaSND
+ jhunew = jhuSND
+ do ksnd = 0, 40
+ tSND(ksnd, 2) = tSND(ksnd, 1)
+ qSND(ksnd, 2) = qSND(ksnd, 1)
+ zSND(ksnd, 2) = zSND(ksnd, 1)
+ pSND(ksnd, 2) = pSND(ksnd, 1)
+ fSND(ksnd, 2) = fSND(ksnd, 1)
+ dSND(ksnd, 2) = dSND(ksnd, 1)
+ enddo
+
+ endif
+
+ ! +- Continue Read
+ ! + ~~~~~~~~~~~~~
+
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(timarn > tiSND2 .and. loSND == 1) go to 200
+ ! +- - -end do until
+ ! + ~~~~~~~~~~~~~
+
+ ! +- STOP Read
+ ! + ~~~~~~~~~~~~~
+
+ close(unit=2)
+
+ ! +- Output Listing
+ ! + ~~~~~~~~~~~~~~~
+ write(4, 205) msnd - intpol, jdaSND, labmGE(mmaSND), iyrSND, &
+ jhuSND, jhuSND + itizGE(iSND, jSND)
+205 format(/, ' SOUNDING No', i2, i6, 1x, a3, i5, i4, ' TU (', i2, ' LT)', &
+ ' --- MARsnd ---', &
+ /, ' =============', &
+ /, ' z (m) | p (Pa) | T (K) | qv (kg/kg) |', &
+ ' ff(m/s) | dd(deg) |' &
+ /, '---------+---------+---------+------------+', &
+ '---------+---------+')
+
+ write(4, 206)(zSND(ksnd, 1), pSND(ksnd, 1), &
+ tSND(ksnd, 1), qSND(ksnd, 1), &
+ fSND(ksnd, 1), dSND(ksnd, 1), ksnd=40, 0, -1)
+206 format((2(f8.0, ' |'), f8.2, ' |', d11.3, ' |', f8.2, ' |', f8.1, ' |'))
+ ! +
+ if(intpol == 1) then
+ write(4, 205) msnd, jdanew, labmGE(mmanew), iyrnew, &
+ jhunew, jhunew + itizGE(iSND, jSND)
+ write(4, 206)(zSND(ksnd, 2), pSND(ksnd, 2), &
+ tSND(ksnd, 2), qSND(ksnd, 2), &
+ fSND(ksnd, 2), dSND(ksnd, 2), ksnd=40, 0, -1)
+ endif
+
+ ! + ------
+ endif
+ ! + ------
+
+ ! +--Additional Variables
+ ! + ====================
+
+ ! +--Time Parameters
+ ! + ---------------
+
+ if(tiSND2 > tiSND1) then
+ gradti = (timarn - tiSND1) / (tiSND2 - tiSND1)
+ graddt = dt / (tiSND2 - tiSND1)
+ else
+ gradti = 0.0
+ graddt = 0.0
+ endif
+
+ ! +--Exner Function and Potential Temperature
+ ! + ----------------------------------------
+
+ do nSND = 1, intpol + 1
+ do ksnd = 0, 40
+ pksnd(ksnd, nSND) = exp(cap * log(dem1 * pSND(ksnd, nSND)))
+ tpSND(ksnd, nSND) = tSND(ksnd, nSND) * pcap / pksnd(ksnd, nSND)
+ enddo
+
+ ! +--Potential Temperature Averaging
+ ! + -------------------------------
+
+ tmsnd(0, nSND) = tpSND(1, nSND)
+ do ksnd = 1, 39
+ tmsnd(ksnd, nSND) = 0.5 * (tpSND(ksnd, nSND) &
+ + tpSND(ksnd + 1, nSND))
+ enddo
+ tmsnd(40, nSND) = tpSND(40, nSND)
+ enddo
+
+ ! + ++++++++++++++
+ ! +--INITIALISATION
+ ! + ++++++++++++++
+
+ ! + ++++++++++++++++
+ if(itexpe == 0) then
+ ! + ++++++++++++++++
+
+ ! +--Reference Sea Level Air Temperature (K)
+ ! + =======================================
+
+#if(NH)
+ taNH = tSND(1, 1)
+#endif
+
+ ! +--Initialisation of the main Thermodynamical Variables
+ ! + Pressure Thickness, Surface Temperature and Specific Humidity
+ ! + =============================================================
+
+ gra = -gravit / RDryAi
+ pstSND = 0.1 * (pSND(1, 1) + gradti * (pSND(1, intpol + 1) - pSND(1, 1))) &
+ - ptopDY
+ tsurf0 = tSND(1, 1) + gradti * (tSND(1, intpol + 1) - tSND(1, 1))
+ qsurf0 = qSND(1, 1) + gradti * (qSND(1, intpol + 1) - qSND(1, 1))
+
+ ! +- Reference Grid Point for Temperature Vertical Profile Initialisation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ishmin = iSND
+ jshmin = jSND
+ ! +... indices for the lowest grid point
+
+ shmin = sh(ishmin, jshmin)
+ distmn = mx + my
+
+ do j = 1, my
+ do i = 1, mx
+
+ if(sh(i, j) < shmin) then
+ ! +... Constraint 1: Reference Grid Point must be the lowest One
+
+ ishmin = i
+ jshmin = j
+ shmin = sh(ishmin, jshmin)
+ distmn = (i - iSND) * (i - iSND) + (j - jSND) * (j - jSND)
+ else
+ if(sh(i, j) == shmin) then
+ ! +... Constraint 2: Reference Grid Point must be the closest One
+ ! + from the Sounding Grid Point
+
+ distij = (i - iSND) * (i - iSND) + (j - jSND) * (j - jSND)
+ if(distij < distmn) then
+ ishmin = i
+ jshmin = j
+ shmin = sh(ishmin, jshmin)
+ distmn = distij
+ endif
+ endif
+ endif
+
+ ! +- Surface Elevation is MSL
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ pstDY(i, j) = pstSND
+ TairSL(i, j) = tsurf0 - dtagSL
+ qvapSL(i, j) = qsurf0
+
+ ! +- Surface Elevation is NOT MSL ==> Integration
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(sh(i, j) /= zero) then
+ ! +
+ do nSND = 1, intpol + 1
+ ! +
+ ksnd = 1
+ ! +... ksnd = 1 (when pSND(mz) -> pSND(0:mz), etc...)
+ ! + zSND(0) = -500m
+ ! +
+ ! + - - - - - do until
+110 continue
+ if(zSND(ksnd, nSND) > sh(i, j)) go to 111
+ ksnd = ksnd + 1
+ go to 110
+111 continue
+ ! + - - - - - end do until
+ ! +
+ pksh = pksnd(ksnd - 1, nSND) &
+ + gravit * (zSND(ksnd - 1, nSND) - sh(i, j)) &
+ * pcap / (cp * tmsnd(ksnd - 1, nSND))
+ pint(nSND) = exp(acap * log(pksh))
+ ! +
+ gsnd = (tSND(ksnd, nSND) - tSND(ksnd - 1, nSND)) &
+ / (zSND(ksnd, nSND) - zSND(ksnd - 1, nSND))
+ tint(nSND) = tSND(ksnd - 1, nSND) &
+ + gsnd * (sh(i, j) - zSND(ksnd - 1, nSND))
+ gsnd = (qSND(ksnd, nSND) - qSND(ksnd - 1, nSND)) &
+ / (zSND(ksnd, nSND) - zSND(ksnd - 1, nSND))
+ qint(nSND) = qSND(ksnd - 1, nSND) &
+ + gsnd * (sh(i, j) - zSND(ksnd - 1, nSND))
+ ! +
+ enddo
+ ! +
+ pstDY(i, j) = pint(1) + gradti * (pint(intpol + 1) - pint(1)) &
+ - ptopDY
+ TairSL(i, j) = tint(1) + gradti * (tint(intpol + 1) - tint(1)) &
+ - dtagSL
+ qvapSL(i, j) = qint(1) + gradti * (qint(intpol + 1) - qint(1))
+ ! +
+ endif
+ ! +
+ ! _SC qmax = qsat0D(TairSL(i,j),unun,pstDY(i,j),ptopDY,lsf)
+ ! _SC qvapSL(i,j) = min (qvapSL(i,j),qmax)
+ ! +... avoids supersaturation (_SC)
+ ! +
+ pstDY1(i, j) = pstDY(i, j)
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Temperature and Specific Humidity Vertical Profiles Initialisation
+ ! + ==================================================================
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ ! +
+ do nSND = 1, intpol + 1
+ ! +
+ ! + **************
+ call inisnd_th(pstDY(i, j), ptopDY, sigmid, sigma, ttij, qvij)
+ ! + **************
+ ! +
+ enddo
+ ! +
+ do k = mz, 1, -1
+ tairDY(i, j, k) = ttij(k, 1) + gradti * (ttij(k, intpol + 1) - ttij(k, 1))
+ ta_inv = min(tairDY(i, j, k), tairDY(i, j, mz) - dtagSL)
+ qvDY(i, j, k) = (qvij(k, 1) + gradti * (qvij(k, intpol + 1) - qvij(k, 1))) &
+ * qsat0D(ta_inv, sigma(k), &
+ pstDY(i, j), ptopDY, lsf) &
+ / qsat0D(tairDY(i, j, k), sigma(k), &
+ pstDY(i, j), ptopDY, lsf)
+ ! +... Last two Lines: Correction for possible Surface Inversion
+ ! +
+ ! _SC qmax = qsat0D(tairDY(i,j,k),sigma(k),
+ ! _SC. pstDY(i,j),ptopDY,lsf)
+ ! _SC qvDY(i,j,k) = min (qvDY(i,j,k),qmax)
+#if(OM)
+ tairDY(i, j, k) = tSND(1, 1) + gradti * (tSND(intpol + 1, 1) - tSND(1, 1))
+ qvDY(i, j, k) = zero
+#endif
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Reduced Potential Temperature Vertical Profiles Initialisation
+ ! + ==================================================================
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, mzz) = TairSL(i, j) &
+ / ((pstDY1(i, j) + ptopDY)**cap)
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, k) = tairDY(i, j, k) &
+ / ((pstDY1(i, j) * sigma(k) + ptopDY)**cap)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +
+ ! +--Geostrophic Wind Vertical Profile 1st Initialisation
+ ! + ====================================================
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ ! +
+ do nSND = 1, intpol + 1
+ ! +
+ ! +
+ ! +--Rotation from x in the West-East Direction to x in Direction GEddxx
+ ! + -------------------------------------------------------------------
+ ! +
+ do ksnd = 0, 40
+ ddnew = (GEddxx - dSND(ksnd, nSND)) * degrad
+ uuSND(ksnd) = fSND(ksnd, nSND) * cos(ddnew)
+ vvSND(ksnd) = fSND(ksnd, nSND) * sin(ddnew)
+ enddo
+ ! +
+ ! +
+ ! +--Vertical Interpolation
+ ! + ----------------------
+ ! +
+ ! + **************
+ call inisnd_vl(pstDY(i, j), ptopDY, sigmid, sigma, ulij, vlij)
+ ! + **************
+ ! +
+ enddo
+ ! +
+ ! +
+ ! +--Time Interpolation
+ ! + ------------------
+ ! +
+ do k = 1, mz
+ ugeoDY(i, j, k) = ulij(k, 1) + gradti * (ulij(k, intpol + 1) - ulij(k, 1))
+ vgeoDY(i, j, k) = vlij(k, 1) + gradti * (vlij(k, intpol + 1) - vlij(k, 1))
+ enddo
+ enddo
+ enddo
+ ! +
+ zetaD = zeSND(1) + gradti * (zeSND(intpol + 1) - zeSND(1))
+ ! +... zetaD: Large Scale Local Vorticity (CAUTION: Time Independant)
+ ! +
+ ! +
+ ! +--Large Scale Wind Vertical Profile 1st Initialisation
+ ! + ====================================================
+ ! +
+ ! +
+ ! +--Auxiliary Variable for Mass Flux Computation
+ ! + --------------------------------------------
+ ! +
+ shmin = 100000.0
+ ! +... shmin : minimum surface elevation (for mass flux computation)
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ if(sh(i, j) < shmin) then
+ i0snd = i
+ j0snd = j
+ shmin = sh(i, j)
+ endif
+ enddo
+ enddo
+#if(PV)
+ ! +--Wind Initialisation, under Constant Potential Vorticity Constraint
+ ! + ------------------------------------------------------------------
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ do k = 1, mz
+ ulscPV(k) = ugeoDY(iSND, jSND, k)
+ vlscPV(k) = vgeoDY(iSND, jSND, k)
+ if(abs(ulscPV(k)) > zero .or. abs(vlscPV(k)) > zero) lvg = 1
+ enddo
+ ! Initialisation based on Potential Vorticity Conservation
+ ! Based on the Direct Integration of the Relative Vorticity
+ ! cCA : inisnd_PV does not exist
+ ! ! + **************
+ ! if (mmx.gt.1.and.lvg.eq.1) call inisnd_PV(zetaD)
+ ! ! + **************
+ else
+ ! +--Wind Initialisation under Constant Mass Flux Constraint
+ ! + -------------------------------------------------------
+#endif
+ if(conmas) then
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = pstDY(i0snd, j0snd) * ugeoDY(i, j, k)
+ WKxyz2(i, j, k) = pstDY(i0snd, j0snd) * vgeoDY(i, j, k)
+ uairDY(i, j, k) = WKxyz1(i, j, k) / pstDY(i, j)
+ vairDY(i, j, k) = WKxyz2(i, j, k) / pstDY(i, j)
+ ! +... Geostrophic Wind only used in Large Scale Press.Grad.Force
+ ! + real Wind takes into Account Mass Conservation
+ ! +
+ enddo
+ enddo
+ enddo
+ ! +
+ if(mmy == 1) then
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ vairDY(i, j, k) = vgeoDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+ else
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ uairDY(i, j, k) = ugeoDY(i, j, k)
+ vairDY(i, j, k) = vgeoDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+#if(PV)
+ endif
+#endif
+ ! +
+ ! +
+ ! +--Output
+ ! + ------
+ ! +
+#if(PV)
+ write(21, 182)(vgeoDY(i, 1, mz), i=1, mx)
+182 format(/, ' Vg(i,1,mz) :', /,(15f8.2))
+ write(21, 183)(vairDY(i, 1, mz), i=1, mx)
+183 format(/, ' V (i,1,mz) :', /,(15f8.2))
+ write(21, 184)(ugeoDY(i, 1, mz), i=1, mx)
+184 format(/, ' Ug(i,1,mz) :', /,(15f8.2))
+ write(21, 185)(uairDY(i, 1, mz), i=1, mx)
+185 format(/, ' U (i,1,mz) :', /,(15f8.2))
+#endif
+ ! +
+ if(IO_loc >= 2) then
+ write(21, 1860)
+1860 format(1x)
+ write(21, 1861)(ugeoDY(iSND, jSND, k), k=1, mz)
+1861 format(' ug =', /,(15f7.1, ' m/sec'))
+ ! +
+#if(PV)
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ write(21, 1860)
+ write(21, 1862) adugPV
+1862 format(' adugPV =', f7.3, ' m/sec')
+ endif
+#endif
+ ! +
+ write(21, 1860)
+ write(21, 1863)(vgeoDY(iSND, jSND, k), k=1, mz)
+1863 format(' vg =', /,(15f7.1, ' m/sec'))
+ ! +
+#if(PV)
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ write(21, 1860)
+ write(21, 1864)(1.d3 * advgPV(iSND, k), k=1, mz)
+1864 format(' advgPV =', /,(15f7.3, ' mm/sec'))
+ endif
+#endif
+ ! +
+ write(21, 1860)
+ endif
+ ! +
+ ! +
+ ! + ++++++
+ endif
+ ! + ++++++
+
+ ! + +++++++++++++++++++++++++++++++++++++
+ ! +--INITIALIZATION of BOUNDARY CONDITIONS
+ ! + +++++++++++++++++++++++++++++++++++++
+
+ ! + ++++++++++++++++++
+ if(itexpe == 0) then
+ ! + ++++++++++++++++++
+
+ ! + ================
+ if(log_1D == 0) then
+ ! + ================
+
+ ! +--Upper
+ ! + -----
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ uairUB(i, j, k) = uairDY(i, j, k)
+ vairUB(i, j, k) = vairDY(i, j, k)
+ pktaUB(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--x Axis
+ ! + ------
+ if(mmx > 1) then
+
+ do k = 1, mz
+
+ do j = 1, my
+ do i = 1, n7mxLB
+ vaxgLB(i, j, k, 1) = uairDY(i, j, k)
+ vaxgLB(i, j, k, 2) = vairDY(i, j, k)
+ vaxgLB(i, j, k, 3) = qvDY(i, j, k)
+ vaxgLB(i, j, k, 4) = pktaDY(i, j, k)
+ vaxgLB(i, j, 1, 5) = pstDY(i, j)
+ enddo
+ do i = mx - n6mxLB, mx
+ vaxdLB(i, j, k, 1) = uairDY(i, j, k)
+ vaxdLB(i, j, k, 2) = vairDY(i, j, k)
+ vaxdLB(i, j, k, 3) = qvDY(i, j, k)
+ vaxdLB(i, j, k, 4) = pktaDY(i, j, k)
+ vaxdLB(i, j, 1, 5) = pstDY(i, j)
+ enddo
+ enddo
+
+ enddo
+
+ endif
+
+ ! +- y Axis
+ ! + ------
+ if(mmy > 1) then
+
+ do k = 1, mz
+
+ do i = 1, mx
+ do j = 1, n7myLB
+ vayiLB(i, j, k, 1) = uairDY(i, j, k)
+ vayiLB(i, j, k, 2) = vairDY(i, j, k)
+ vayiLB(i, j, k, 3) = qvDY(i, j, k)
+ vayiLB(i, j, k, 4) = pktaDY(i, j, k)
+ vayiLB(i, j, 1, 5) = pstDY(i, j)
+ enddo
+ do j = my - n6myLB, my
+ vaysLB(i, j, k, 1) = uairDY(i, j, k)
+ vaysLB(i, j, k, 2) = vairDY(i, j, k)
+ vaysLB(i, j, k, 3) = qvDY(i, j, k)
+ vaysLB(i, j, k, 4) = pktaDY(i, j, k)
+ vaysLB(i, j, 1, 5) = pstDY(i, j)
+ enddo
+ enddo
+
+ enddo
+
+ endif
+
+ ! + ====
+ else
+ ! + ====
+
+ if(tequil > 0.0) then
+
+ ! +--Upper
+ ! + -----
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ uairUB(i, j, k) = uairDY(i, j, k)
+ vairUB(i, j, k) = vairDY(i, j, k)
+ pktaUB(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--x Axis
+ ! + ------
+ if(mmx > 1) then
+
+ do k = 1, mz
+
+ do j = 1, my
+ do i = 2, n7mxLB
+ vaxgLB(i, j, k, 1) = uairDY(i, j, k)
+ vaxgLB(i, j, k, 2) = vairDY(i, j, k)
+ vaxgLB(i, j, 1, 5) = pstDYn(i, j)
+ enddo
+ vaxgLB(1, j, k, 1) = uairDY(ip11 - lbcfix, j, k)
+ vaxgLB(1, j, k, 2) = vairDY(ip11 - lbcfix, j, k)
+ vaxgLB(1, j, 1, 5) = pstDYn(ip11 - lbcfix, j)
+
+ do i = mx - n6mxLB, mx1
+ vaxdLB(i, j, k, 1) = uairDY(i, j, k)
+ vaxdLB(i, j, k, 2) = vairDY(i, j, k)
+ vaxdLB(i, j, 1, 5) = pstDYn(i, j)
+ enddo
+ vaxdLB(mx, j, k, 1) = uairDY(mx1 + lbcfix, j, k)
+ vaxdLB(mx, j, k, 2) = vairDY(mx1 + lbcfix, j, k)
+ vaxdLB(mx, j, 1, 5) = pstDYn(mx1 + lbcfix, j)
+ enddo
+
+ enddo
+
+ endif
+
+ ! +- y Axis
+ ! + ------
+ if(mmy > 1) then
+
+ do k = 1, mz
+
+ do i = 1, mx
+ do j = 1, n7myLB
+ vayiLB(i, j, k, 1) = uairDY(i, j, k)
+ vayiLB(i, j, k, 2) = vairDY(i, j, k)
+ vayiLB(i, j, k, 5) = pstDYn(i, j)
+ enddo
+ vayiLB(i, 1, k, 1) = uairDY(i, jp11 - lbcfix, k)
+ vayiLB(i, 1, k, 2) = vairDY(i, jp11 - lbcfix, k)
+ vayiLB(i, 1, k, 5) = pstDYn(i, jp11 - lbcfix)
+ do j = my - n6myLB, my1
+ vaysLB(i, j, k, 1) = uairDY(i, j, k)
+ vaysLB(i, j, k, 2) = vairDY(i, j, k)
+ vaysLB(i, j, k, 5) = pstDYn(i, j)
+ enddo
+ vaysLB(i, my, k, 1) = uairDY(i, my1 + lbcfix, k)
+ vaysLB(i, my, k, 2) = vairDY(i, my1 + lbcfix, k)
+ vaysLB(i, my, k, 5) = pstDYn(i, my1 + lbcfix)
+ enddo
+
+ enddo
+
+ endif
+
+ endif
+
+ ! + ======
+ endif
+ ! + ======
+
+ ! + +++++++++++++++++++++++++++++++++++++
+ ! +--UPDATE of LATERAL BOUNDARY CONDITIONS
+ ! + +++++++++++++++++++++++++++++++++++++
+ ! +
+ ! + ++++
+ else
+ ! + ++++
+ ! +
+ ! +
+ ! + ================
+ if(intpol > 0) then
+ ! + ================
+ ! +
+ ! +
+ ! +--Temperature and Specific Humidity Vertical Profiles Interpolation
+ ! + =================================================================
+ ! +
+ ! +
+ ! +--x Axis / x <<
+ ! + -------------
+ ! +
+ if(mmx > 1) then
+ ! +
+ i = 1
+ do j = 1, my
+#if(pv)
+ i = iSND
+#endif
+ ! +
+ ! +- Vertical Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ do nSND = 1, 2
+ ! +
+ ! + **************
+ call inisnd_th(pstDY(i, j), ptopDY, sigmid, sigma, ttij, qvij)
+ ! + **************
+ ! +
+ enddo
+#if(pv)
+ ! CAUTION: vaxgLB assumed at i=1 assumed to be that of the Sounding Point
+ ! when Potential Temperature is conserved at the Synoptic Scale
+ i = 1
+#endif
+ ! +
+ ! +- Time Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ dpt(k) = (ttij(k, 1) + gradti * (ttij(k, 2) - ttij(k, 1))) &
+ / exp(cap * log(pstDY(i, j) * sigma(k) + ptopDY)) &
+ - vaxgLB(i, j, k, 4)
+ dqa(k) = qvij(k, 1) + gradti * (qvij(k, 2) - qvij(k, 1)) &
+ - vaxgLB(i, j, k, 3)
+ enddo
+ ! +
+ if(openLB) then
+ do ii = 1, n7mxLB
+ do k = 1, mz
+ vaxgLB(ii, j, k, 4) = vaxgLB(ii, j, k, 4) + dpt(k)
+ vaxgLB(ii, j, k, 3) = vaxgLB(ii, j, k, 3) + dqa(k)
+ enddo
+ enddo
+ else
+ do ii = 1, n7mxLB
+ do k = 1, mz
+ vaxgLB(ii, j, k, 4) = pktaDY(1, j, k) + dpt(k)
+ vaxgLB(ii, j, k, 3) = qvDY(1, j, k) + dqa(k)
+ enddo
+ enddo
+ endif
+ ! +
+ enddo
+ ! +
+ ! +
+ ! +- x Axis / x >>
+ ! + -------------
+ ! +
+ i = mx
+ do j = 1, my
+#if(pv)
+ i = iSND
+#endif
+ ! +
+ ! +- Vertical Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ do nSND = 1, 2
+ ! +
+ ! + **************
+ call inisnd_th(pstDY(i, j), ptopDY, sigmid, sigma, ttij, qvij)
+ ! + **************
+ ! +
+ enddo
+ ! +
+#if(pv)
+ i = mx
+#endif
+ ! +
+ ! +- Time Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ dpt(k) = (ttij(k, 1) + gradti * (ttij(k, 2) - ttij(k, 1))) &
+ / exp(cap * log(pstDY(i, j) * sigma(k) + ptopDY)) &
+ - vaxdLB(i, j, k, 4)
+ dqa(k) = qvij(k, 1) + gradti * (qvij(k, 2) - qvij(k, 1)) &
+ - vaxdLB(i, j, k, 3)
+ enddo
+ ttij_1 = ttij(mz, 1)
+ ttij_2 = ttij(mz, 2)
+ ! +
+ if(openLB) then
+ do ii = mx - n6mxLB, mx
+ do k = 1, mz
+ vaxdLB(ii, j, k, 4) = vaxdLB(ii, j, k, 4) + dpt(k)
+ vaxdLB(ii, j, k, 3) = vaxdLB(ii, j, k, 3) + dqa(k)
+ enddo
+ enddo
+ else
+ do ii = mx - n6mxLB, mx
+ do k = 1, mz
+ vaxdLB(ii, j, k, 4) = pktaDY(mx, j, k) + dpt(k)
+ vaxdLB(ii, j, k, 3) = qvDY(mx, j, k) + dqa(k)
+ enddo
+ enddo
+ endif
+ ! +
+ enddo
+ ! +
+#if(WR)
+ if(mod(minuGE, 30) == 0 .and. jsecGE == 0) then
+ write(6, 608) mmaSND, jdaSND, jhuSND + itizGE(iSND, jSND), &
+ mmarGE, jdarGE, jhurGE, &
+ mmanew, jdanew, jhunew + itizGE(iSND, jSND), &
+ tiSND1, timmar, tiSND2, &
+ gradti, vaxdLB(mx, my, mz, 4) * pcap
+608 format(3(i6, '/', i2, '/', i2, 'LT'), 3f13.0, &
+ ' |Time| =', f5.2, 5x, ' Theta_CLS =', f7.2)
+ endif
+#endif
+ ! +
+ ENDif ! {end mmx > 1} CTR
+ ! +
+ ! +
+ ! +- y Axis / y <<
+ ! + -------------
+ ! +
+ if(mmy > 1) then
+ ! +
+ j = 1
+ do i = 1, mx
+ ! +
+ ! +- Vertical Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ do nSND = 1, 2
+ ! +
+ ! + **************
+ call inisnd_th(pstDY(i, j), ptopDY, sigmid, sigma, ttij, qvij)
+ ! + **************
+ ! +
+ enddo
+ ! +
+ ! +- Time Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ dpt(k) = (ttij(k, 1) + gradti * (ttij(k, 2) - ttij(k, 1))) &
+ / exp(cap * log(pstDY(i, j) * sigma(k) + ptopDY)) &
+ - vayiLB(i, j, k, 4)
+ dqa(k) = qvij(k, 1) + gradti * (qvij(k, 2) - qvij(k, 1)) &
+ - vayiLB(i, j, k, 3)
+ enddo
+ ! +
+ if(openLB) then
+ do jj = 1, n7myLB
+ do k = 1, mz
+ vayiLB(i, jj, k, 4) = vayiLB(i, jj, k, 4) + dpt(k)
+ vayiLB(i, jj, k, 3) = vayiLB(i, jj, k, 3) + dqa(k)
+ enddo
+ enddo
+ else
+ do jj = 1, n7myLB
+ do k = 1, mz
+ vayiLB(i, jj, k, 4) = pktaDY(i, 1, k) + dpt(k)
+ vayiLB(i, jj, k, 3) = qvDY(i, 1, k) + dqa(k)
+ enddo
+ enddo
+ endif
+ ! +
+ enddo
+ ! +
+ ! +
+ ! +- y Axis / y >>
+ ! + -------------
+ ! +
+ j = my
+ do i = 1, mx
+ ! +
+ ! +- Vertical Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ do nSND = 1, 2
+ ! +
+ ! + **************
+ call inisnd_th(pstDY(i, j), ptopDY, sigmid, sigma, ttij, qvij)
+ ! + **************
+ ! +
+ enddo
+ ! +
+ ! +- Time Interpolation
+ ! + ~~~~~~~~~~~~~~~~~~~
+ do k = 1, mz
+ dpt(k) = (ttij(k, 1) + gradti * (ttij(k, 2) - ttij(k, 1))) &
+ / exp(cap * log(pstDY(i, j) * sigma(k) + ptopDY)) &
+ - vaysLB(i, j, k, 4)
+ dqa(k) = qvij(k, 1) + gradti * (qvij(k, 2) - qvij(k, 1)) &
+ - vaysLB(i, j, k, 3)
+ enddo
+ ! +
+ if(openLB) then
+ do jj = my - n6myLB, my
+ do k = 1, mz
+ vaysLB(i, jj, k, 4) = vaysLB(i, jj, k, 4) + dpt(k)
+ vaysLB(i, jj, k, 3) = vaysLB(i, jj, k, 3) + dqa(k)
+ enddo
+ enddo
+ else
+ do jj = my - n6myLB, my
+ do k = 1, mz
+ vaysLB(i, jj, k, 4) = pktaDY(i, my, k) + dpt(k)
+ vaysLB(i, jj, k, 3) = qvDY(i, my, k) + dqa(k)
+ enddo
+ enddo
+ endif
+ ! +
+ enddo
+ ! +
+ ENDif ! {end mmy > 1} CTR
+ ! +
+ ! +
+ ! +--Large Scale Wind Vertical Profiles Interpolation / Dynamical Adjustment
+ ! + =======================================================================
+ ! +
+ ! +
+ ! +--Mass Flux Auxiliary Variable
+ ! + ----------------------------
+ ! +
+ if(conmas) then
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = pstDY1(iSND, jSND) / pstDY1(i, j)
+ enddo
+ enddo
+ ! +
+ else
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 1.0
+ enddo
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--Large Scale Wind Sounding: Default
+ ! + ----------------------------------
+ ! +
+ do k = 1, mz
+ dug(k) = 0.0
+ dvg(k) = 0.0
+ enddo
+ ! +
+ ! +
+ ! +--Rotation from x in the West-East Direction to x in Direction GEddxx
+ ! + -------------------------------------------------------------------
+ ! +
+ do nSND = 1, intpol + 1
+ do ksnd = 0, 40
+ ddnew = (GEddxx - dSND(ksnd, nSND)) * degrad
+ uuSND(ksnd) = fSND(ksnd, nSND) * cos(ddnew)
+ vvSND(ksnd) = fSND(ksnd, nSND) * sin(ddnew)
+ enddo
+ ! +
+ ! +
+ ! +--Vertical Interpolation
+ ! + ----------------------
+ ! +
+ ! + **************
+ call inisnd_vl(pstDY(iSND, jSND), ptopDY, sigmid, sigma, &
+ ulij, vlij)
+ ! + **************
+ ! +
+ enddo
+ ! +
+ ! +
+ ! +--Time Interpolation
+ ! + ------------------
+ ! +
+ do k = 1, mz
+ dug(k) = graddt * (ulij(k, intpol + 1) - ulij(k, 1))
+ dvg(k) = graddt * (vlij(k, intpol + 1) - vlij(k, 1))
+ enddo
+#if(PV)
+ ! +--Update of Direct Integration of Wind constrained by PV Conservation
+ ! + -------------------------------------------------------------------
+ ! +
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ do k = 1, mz
+ ulscPV(k) = ulscPV(k) + dug(k)
+ vlscPV(k) = vlscPV(k) + dvg(k)
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ advbPV(i, k) = advbPV(i, k) + dvg(k)
+ enddo
+ enddo
+ enddo
+ endif
+ ! +- PV Conservation
+ ! + ~~~~~~~~~~~~~~~~~
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ! PV Conservation Constraint is included
+ ugeoDY(i, j, k) = adugPV * ulscPV(k)
+ vgeoDY(i, j, k) = advbPV(i, k) &
+ + advgPV(i, k) * ugeoDY(i, j, k) * ugeoDY(i, j, k)
+ dul = dug(k) * adugPV * adubPV(i, k)
+ ! uairDY_Synop := uairDY +dul
+ ! vairDY_Synop := vairDY +dvg(k)
+ ! isallobaric wind contained in (dul,dvl=dvg)
+ ugeoDY(i, j, k) = ugeoDY(i, j, k) + dvg(k) &
+ / (fcorDY(imez, jmez) * dt)
+ vgeoDY(i, j, k) = vgeoDY(i, j, k) - dul &
+ / (fcorDY(imez, jmez) * dt)
+ enddo
+ enddo
+ enddo
+ else
+#endif
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ugeoDY(i, j, k) = ugeoDY(i, j, k) + dug(k)
+ vgeoDY(i, j, k) = vgeoDY(i, j, k) + dvg(k)
+ uairDY(i, j, k) = uairDY(i, j, k) + dug(k) * WKxy1(i, j)
+ vairDY(i, j, k) = vairDY(i, j, k) + dvg(k) * WKxy1(i, j)
+ enddo
+ enddo
+ enddo
+#if(PV)
+ endif
+#endif
+ ! +
+ ! +
+ ! +--Lateral Boundaries
+ ! + ------------------
+ ! +
+ if(openLB) then
+ ! +
+ ! +- x Axis / x <<
+ ! + ~~~~~~~~~~~~~
+ do i = 1, n7mxLB
+ do j = 1, my
+#if(PV)
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ do k = 1, mz
+ vaxgLB(i, j, k, 1) = &
+ vaxgLB(i, j, k, 1) + dug(k) * adubPV(i, k) * adugPV
+ vaxgLB(i, j, k, 2) = &
+ vaxgLB(i, j, k, 2) + dvg(k)
+ enddo
+ else
+#endif
+ do k = 1, mz
+ vaxgLB(i, j, k, 1) = &
+ vaxgLB(i, j, k, 1) + dug(k) * WKxy1(i, j)
+ vaxgLB(i, j, k, 2) = &
+ vaxgLB(i, j, k, 2) + dvg(k) * WKxy1(i, j)
+ enddo
+#if(PV)
+ endif
+#endif
+ enddo
+ enddo
+ ! +
+ ! +- x Axis / x >>
+ ! + ~~~~~~~~~~~~~
+ do i = mx - n6mxLB, mx
+ do j = 1, my
+#if(PV)
+ if(potvor .and. mmx > 1 .and. mmy == 1) then
+ do k = 1, mz
+ vaxdLB(i, j, k, 1) = &
+ vaxdLB(i, j, k, 1) + dug(k) * adubPV(i, k) * adugPV
+ vaxdLB(i, j, k, 2) = &
+ vaxdLB(i, j, k, 2) + dvg(k)
+ enddo
+ else
+#endif
+ do k = 1, mz
+ vaxdLB(i, j, k, 1) = &
+ vaxdLB(i, j, k, 1) + dug(k) * WKxy1(i, j)
+ vaxdLB(i, j, k, 2) = &
+ vaxdLB(i, j, k, 2) + dvg(k) * WKxy1(i, j)
+ enddo
+#if(PV)
+ endif
+#endif
+ enddo
+ enddo
+ ! +
+ ! +- y Axis / y <<
+ ! + ~~~~~~~~~~~~~
+ if(mmy > 1) then
+ ! +
+ do i = 1, mx
+ do j = 1, n7myLB
+ do k = 1, mz
+ vayiLB(i, j, k, 1) = &
+ vayiLB(i, j, k, 1) + dug(k) * WKxy1(i, j)
+ vayiLB(i, j, k, 2) = &
+ vayiLB(i, j, k, 2) + dvg(k) * WKxy1(i, j)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +- y Axis / y >>
+ ! + ~~~~~~~~~~~~~
+ do i = 1, mx
+ do j = my - n6myLB, my
+ do k = 1, mz
+ vaysLB(i, j, k, 1) = &
+ vaysLB(i, j, k, 1) + dug(k) * WKxy1(i, j)
+ vaysLB(i, j, k, 2) = &
+ vaysLB(i, j, k, 2) + dvg(k) * WKxy1(i, j)
+ enddo
+ enddo
+ enddo
+ ! +
+ endif
+ ! +
+ else ! {end openLB / begin .not. openLB} CTR
+ ! +
+ ! +- x Axis / x <<
+ ! + ~~~~~~~~~~~~~
+ if(mmx > 1) then
+ do i = 1, n7mxLB
+ do j = 1, my
+ do k = 1, mz
+ vaxgLB(i, j, k, 1) = uairDY(1, j, k)
+ vaxgLB(i, j, k, 2) = vairDY(1, j, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +- x Axis / x >>
+ ! + ~~~~~~~~~~~~~
+ do i = mx - n6mxLB, mx
+ do j = 1, my
+ do k = 1, mz
+ vaxdLB(i, j, k, 1) = uairDY(mx, j, k)
+ vaxdLB(i, j, k, 2) = vairDY(mx, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+ ! +
+ ! +- y Axis / y <<
+ ! + ~~~~~~~~~~~~~
+ if(mmy > 1) then
+ do k = 1, mz
+ do j = 1, n7myLB
+ do i = 1, mx
+ vayiLB(i, j, k, 1) = uairDY(i, 1, k)
+ vayiLB(i, j, k, 2) = vairDY(i, 1, k)
+ enddo
+ enddo
+ enddo
+ ! +
+ ! +- y Axis / y >>
+ ! + ~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, n7myLB
+ do i = 1, mx
+ vaysLB(i, j, k, 1) = uairDY(i, my, k)
+ vaysLB(i, j, k, 2) = vairDY(i, my, k)
+ enddo
+ enddo
+ enddo
+ endif
+ ENDif ! {end .not. openLB} CTR
+ ! +
+ ! + ======
+ endif
+ ! + ======
+ ! +
+ ! +
+ ! + ++++++
+ endif
+ ! + ++++++
+ ! +
+ ! +
+ ! +--OUTPUT (Each Hour)
+ ! + ==================
+ ! +
+ ! + --------------------------------
+ if(minuGE == 0 .and. jsecGE == 0) then
+ ! + --------------------------------
+ ! +
+ do nSND = 1, 2
+ fftt(nSND) = sqrt(ulij(mz, nSND) * ulij(mz, nSND) &
+ + vlij(mz, nSND) * vlij(mz, nSND))
+ if(ulij(mz, nSND) /= 0.0) then
+ ddtt(nSND) = atan(vlij(mz, nSND) / ulij(mz, nSND))
+ if(ulij(mz, nSND) < zero) &
+ ddtt(nSND) = ddtt(nSND) + pi
+ else
+ if(vlij(mz, nSND) > zero) then
+ ddtt(nSND) = 0.5 * pi
+ else
+ ddtt(nSND) = -0.5 * pi
+ endif
+ endif
+ enddo
+ ! +
+ fftt(3) = sqrt(ugeoDY(iSND, jSND, mz) * ugeoDY(iSND, jSND, mz) &
+ + vgeoDY(iSND, jSND, mz) * vgeoDY(iSND, jSND, mz))
+ if(ugeoDY(iSND, jSND, mz) /= zero) then
+ ddtt(3) = atan(vgeoDY(iSND, jSND, mz) / ugeoDY(iSND, jSND, mz))
+ if(ugeoDY(iSND, jSND, mz) < zero) &
+ ddtt(3) = ddtt(nSND) + pi
+ else
+ if(vgeoDY(iSND, jSND, mz) > zero) then
+ ddtt(3) = 0.5 * pi
+ else
+ ddtt(3) = -0.5 * pi
+ endif
+ endif
+ ! +
+ do nSND = 1, 3
+ ddtt(nSND) = ddtt(nSND) * 180.0 / pi
+ ddtt(nSND) = -ddtt(nSND) + 90.0
+ enddo
+ ! +
+ write(4, 442)
+442 format( &
+ /, ' yyyy-MM-jj-UT-mm | uL m/s | vL m/s | VL m/s | dd deg |', &
+ ' T(mx,mz) K |', &
+ /, ' -----------------+---------+---------+---------+---------+', &
+ '------------+')
+ ! +
+ i = iSND
+ j = jSND
+ ! +
+ ! + ***********
+ call TIMcor(i, j)
+ ! + ***********
+ ! +
+ write(4, 443) iyrSND, mmaSND, jdaSND, jhuSND, izr, &
+ ulij(mz, 1), vlij(mz, 1), &
+ fftt(1), ddtt(1), ttij_1
+ write(4, 443) iyrrGE, mmplus, jdplus, jhurGE, minuGE, &
+ ugeoDY(iSND, jSND, mz), vgeoDY(iSND, jSND, mz), &
+ fftt(3), ddtt(3), &
+ vaxdLB(mx, 1, mz, 4) &
+ * exp(cap * log(pstDY(mx, 1) * sigma(mz) + ptopDY))
+ if(mmanew > 0) &
+ write(4, 443) iyrnew, mmanew, jdanew, jhunew, izr, &
+ ulij(mz, 2), vlij(mz, 2), &
+ fftt(2), ddtt(2), ttij_2
+443 format(i5, 4('-', i2), &
+ ' |', f8.2, ' |', f8.2, ' |', f8.2, ' |', f8.1, ' |', &
+ f10.3, ' |')
+ write(4, 444)
+444 format(/, 1x)
+ ! +
+ ! +
+ ! + ------
+ endif
+ ! + ------
+ ! +
+ ! +
+ ! +--Work Arrays Reset
+ ! + =================
+ ! +
+ ! +
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ enddo
+ enddo
+ ! +
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ return
+endsubroutine inisnd
diff --git a/MAR/code_mar/inisnd_th.f90 b/MAR/code_mar/inisnd_th.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c2122181db72e275666d01bd70edb1403aef7e18
--- /dev/null
+++ b/MAR/code_mar/inisnd_th.f90
@@ -0,0 +1,158 @@
+#include "MAR_pp.def"
+subroutine inisnd_th(pij, ptopDY, sigmid, sigma, t_ij, q_ij)
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT ATMOS 25-09-2001 MAR |
+ ! | subroutine inisnd_th initializes |
+ ! | ATMOSPHERIC TEMPERATURES and SPECIFIC HUMIDITIES vertical profiles |
+ ! | from sounding data (observations or academic situation) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: pij -> pstDY (i,j) : Model Pressure Thickness |
+ ! | ^^^^^ ptopDY Model Pressure Top |
+ ! | sigmid Model Layer Interface Coordinate |
+ ! | sigma Model Level Coordinate |
+ ! | |
+ ! | INPUT (via common) |
+ ! | ^^^^^ tpSND Sounding Potential Temperature |
+ ! | |
+ ! | OUTPUT: t_ij -> tairDY(i,j,1->mz) |
+ ! | ^^^^^^ q_ij -> qvDY(i,j,1->mz) |
+ ! | |
+ ! | CAUTION: The Sounding must be in Hydrostatic Balance |
+ ! | ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marphy
+ use mardim
+ use marsnd
+ ! +
+ implicit none
+ ! +
+ ! +
+ real pij, ptopDY
+ real sigmid(mzz)
+ real sigma(mz)
+ ! +
+ real t_ij(mz, 2), q_ij(mz, 2)
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer k, ksnd, lsnd
+ real gra, prl, pr1, pr2
+ real gsnd, tt1, tt2, ttav
+ real gqv, qv1, qv2, qvav
+ ! +
+ ! +
+ ! +--Scheme Initialisation
+ ! + =====================
+ ! +
+ gra = -gravit / RDryAi
+ ! +
+ ! +--Temperature Vertical Profile
+ ! + ============================
+ ! +
+ k = mz
+ ksnd = 1
+ ! +... ksnd = 1 (when pSND(mz) -> pSND(0:mz), etc...)
+ ! +
+ ! + - -do until
+100 continue
+ prl = pij * sigma(k) + ptopDY
+ if(k == 1) then
+ pr1 = (pij * 0.5 * sigma(1) + ptopDY) * 10.0
+ else
+ pr1 = (pij * sigmid(k) + ptopDY) * 10.0
+ endif
+ pr2 = (pij * sigmid(k + 1) + ptopDY) * 10.0
+ ! +... Factor 10 is needed for [cb] --> [mb]
+ ! +
+ ! + - - do until
+110 continue
+ if(pSND(ksnd, nSND) < pr2) go to 111
+ ksnd = ksnd + 1
+ go to 110
+111 continue
+ ! + - - end do
+ ! +
+ gsnd = (tpSND(ksnd, nSND) - tpSND(ksnd - 1, nSND)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ tt2 = tpSND(ksnd - 1, nSND) + gsnd * (pr2 - pSND(ksnd - 1, nSND))
+ ! +
+ gqv = (qsnd(ksnd, nSND) - qSND(ksnd - 1, nSND)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ qv2 = qSND(ksnd - 1, nSND) + gqv * (pr2 - pSND(ksnd - 1, nSND))
+ ! +
+ if(pSND(ksnd, nSND) >= pr1) then
+ ttav = (tt2 + tpSND(ksnd, nSND)) &
+ * (pr2 - pSND(ksnd, nSND))
+ qvav = (qv2 + qSND(ksnd, nSND)) &
+ * (pr2 - pSND(ksnd, nSND))
+ else
+ ttav = zero
+ qvav = zero
+ endif
+ ! +
+ ! + - - do until
+ lsnd = 0
+120 continue
+ if(pSND(ksnd, nSND) < pr1) go to 121
+ ksnd = ksnd + 1
+ lsnd = 1
+ if(pSND(ksnd, nSND) >= pr1) then
+ ttav = ttav &
+ + (tpSND(ksnd - 1, nSND) + tpSND(ksnd, nSND)) &
+ * (pSND(ksnd - 1, nSND) - pSND(ksnd, nSND))
+ qvav = qvav &
+ + (qSND(ksnd - 1, nSND) + qSND(ksnd, nSND)) &
+ * (pSND(ksnd - 1, nSND) - pSND(ksnd, nSND))
+ else
+ gsnd = (tpSND(ksnd, nSND) - tpSND(ksnd - 1, nSND)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ tt1 = tpSND(ksnd - 1, nSND) + gsnd * (pr1 - pSND(ksnd - 1, nSND))
+ ttav = ttav &
+ + (tpSND(ksnd - 1, nSND) + tt1) &
+ * (pSND(ksnd - 1, nSND) - pr1)
+ ttav = ttav * 0.5 / (pr2 - pr1)
+ ! +
+ gqv = (qSND(ksnd, nSND) - qSND(ksnd - 1, nSND)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ qv1 = qSND(ksnd - 1, nSND) + gqv * (pr1 - pSND(ksnd - 1, nSND))
+ qvav = qvav &
+ + (qSND(ksnd - 1, nSND) + qv1) &
+ * (pSND(ksnd - 1, nSND) - pr1)
+ qvav = qvav * 0.5 / (pr2 - pr1)
+ endif
+ go to 120
+121 continue
+ ! + - - end do
+ ! +
+ if(lsnd == 0) then
+ tt1 = tpSND(ksnd - 1, nSND) + gsnd * (pr1 - pSND(ksnd - 1, nSND))
+ ttav = (tt2 + tt1) * 0.5
+ ! +
+ qv1 = qSND(ksnd - 1, nSND) + gqv * (pr1 - pSND(ksnd - 1, nSND))
+ qvav = (qv2 + qv1) * 0.5
+ endif
+ ! +
+ ! +
+ ! +--Interpolated/Integrated Values
+ ! + ==============================
+ ! +
+ t_ij(k, nSND) = ttav * prl**cap / pcap
+ q_ij(k, nSND) = qvav
+ ! +
+ ! +
+ ! +--Continue Interpolation
+ ! + ======================
+ ! +
+ if(k <= 1) go to 101
+ k = k - 1
+ go to 100
+101 continue
+ ! + - -end do
+ ! +
+ return
+endsubroutine inisnd_th
diff --git a/MAR/code_mar/inisnd_vl.f90 b/MAR/code_mar/inisnd_vl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d46cd89251e9a12ed189dd62eee4c66377bc93cf
--- /dev/null
+++ b/MAR/code_mar/inisnd_vl.f90
@@ -0,0 +1,146 @@
+#include "MAR_pp.def"
+subroutine inisnd_vl(pij, ptopDY, sigmid, sigma, u_ij, v_ij)
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT ATMOS 17-02-2004 MAR |
+ ! | subroutine inisnd_vl initializes |
+ ! | HORIZONTAL WIND COMPONENTS vertical profiles |
+ ! | from sounding data (observations or academic situation) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: pij -> pstDY (i,j) : Model Pressure Thickness |
+ ! | ^^^^^ ptopDY Model Pressure Top |
+ ! | sigmid Model Layer Interface Coordinate |
+ ! | sigma Model Level Coordinate |
+ ! | |
+ ! | INPUT (via common) |
+ ! | ^^^^^ uuSND Sounding U-Wind Speed |
+ ! | vvSND Sounding V-Wind Speed |
+ ! | |
+ ! | OUTPUT: u_ij -> ugeoDY(i,j,1->mz) |
+ ! | ^^^^^^ v_ij -> vgeoDY(i,j,1->mz) |
+ ! | |
+ ! | CAUTION: non-zero loav generates erroneous results |
+ ! | ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use marsnd
+
+ implicit none
+
+ real pij, ptopDY
+ real sigma(mz)
+ real sigmid(mzz)
+
+ real u_ij(mz, 2), v_ij(mz, 2)
+
+ ! +--Local Variables
+ ! + ================
+
+ integer k, ksnd, loav
+ real gra, prl, pr1, pr2
+ real guu, uu1, uu2, uuav
+ real gvv, vv1, vv2, vvav
+
+ ! +--Scheme Initialisation
+ ! + =====================
+
+ gra = -gravit / RDryAi
+ loav = 0
+
+ ! +--Geostrophic Wind Vertical Profile
+ ! + =================================
+
+ k = mz
+ ksnd = 1
+ ! +... ksnd = 1 (when pSND(mz) -> pSND(0:mz), etc...)
+
+ ! + - -do until
+100 continue
+ if(k == 1) then
+ pr1 = pij * 0.5d1 * sigma(1) + ptopDY
+ else
+ pr1 = pij * 1.0d1 * sigmid(k) + ptopDY
+ endif
+ pr2 = pij * 1.0d1 * sigmid(k + 1) + ptopDY
+ ! +... Factor 10 is needed for [cb] --> [mb]
+
+ ! + - - do until
+110 continue
+ if(pSND(ksnd, nSND) < pr2) go to 111
+ ksnd = ksnd + 1
+ go to 110
+111 continue
+ ! + - - end do
+
+ guu = (uuSND(ksnd) - uuSND(ksnd - 1)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ uu2 = uuSND(ksnd - 1) + guu * (pr2 - pSND(ksnd - 1, nSND))
+ gvv = (vvSND(ksnd) - vvSND(ksnd - 1)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ vv2 = vvSND(ksnd - 1) + gvv * (pr2 - pSND(ksnd - 1, nSND))
+
+ if(pSND(ksnd, nSND) >= pr1) then
+ uuav = -(uu2 + uuSND(ksnd)) &
+ * (pr2 - pSND(ksnd, nSND)) * 0.5
+ vvav = -(vv2 + vvSND(ksnd)) &
+ * (pr2 - pSND(ksnd, nSND)) * 0.5
+ else
+ loav = 0
+ uuav = zero
+ vvav = zero
+ endif
+
+ ! + - - do until
+120 continue
+ if(pSND(ksnd, nSND) < pr1) go to 121
+ ksnd = ksnd + 1
+ go to 120
+121 continue
+ ! + - - end do
+
+ guu = (uuSND(ksnd) - uuSND(ksnd - 1)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ uu1 = uuSND(ksnd - 1) + guu * (pr1 - pSND(ksnd - 1, nSND))
+ gvv = (vvSND(ksnd) - vvSND(ksnd - 1)) &
+ / (pSND(ksnd, nSND) - pSND(ksnd - 1, nSND))
+ vv1 = vvSND(ksnd - 1) + gvv * (pr1 - pSND(ksnd - 1, nSND))
+
+ if(loav > 0) then
+ uuav = uuav &
+ + (uuSND(ksnd - 1) + uu1) &
+ * (pSND(ksnd - 1, nSND) - pr1) * 0.5
+ vvav = vvav &
+ + (vvSND(ksnd - 1) + vv1) &
+ * (pSND(ksnd - 1, nSND) - pr1) * 0.5
+ else
+ uuav = &
+ (uu2 + uu1) &
+ * (pr2 - pr1) * 0.5
+ vvav = &
+ (vv2 + vv1) &
+ * (pr2 - pr1) * 0.5
+ endif
+
+ ! +--Layer Average
+ ! + =============
+
+ uuav = uuav / (pr2 - pr1)
+ vvav = vvav / (pr2 - pr1)
+
+ ! +--Large Scale Wind Components in the MAR Coordinate System
+ ! + ========================================================
+
+ u_ij(k, nSND) = uuav
+ v_ij(k, nSND) = vvav
+
+ if(k <= 1) go to 101
+ k = k - 1
+ go to 100
+101 continue
+ ! + - -end do
+
+ return
+end
diff --git a/MAR/code_mar/iniubc.f90 b/MAR/code_mar/iniubc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f8091cd8d6c5ae157117e8c89f8a81f20d22c2b9
--- /dev/null
+++ b/MAR/code_mar/iniubc.f90
@@ -0,0 +1,184 @@
+#include "MAR_pp.def"
+subroutine INIubc(ihamr_ubc, nhamr_ubc, newubcINI)
+ ! +------------------------------------------------------------------------+
+ ! | MAR INPUT Upper Sponge Thu 05-11-2009 MAR |
+ ! | subroutine INIubc is used to initialize MAR Upper Sponge Refer.State |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: ihamr_ubc: Time Digital Filter Status |
+ ! | ^^^^^ nhamr_ubc: Time Digital Filter Set Up |
+ ! | |
+ ! | OUTPUT: newubcINI: (0,1) ==> (NO new ubc , new ubc) |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | OUTPUT: uairUB: Current x-Wind Speed Component |
+ ! | ^^^^^^^ ua1_UB: Previous Nesting Time Step x-Wind Speed Component |
+ ! | ua2_UB: Next Nesting Time Step x-Wind Speed Component |
+ ! | vairUB, va1_UB, va2_UB, pktaUB, pkt1UB, pkt2UB: idem |
+ ! | tim1UB,tim2UB: Times n, n+1 of uairUB, vairUB, pktaUB |
+ ! | |
+ ! | CAUTION: It is assumed that tim1UB and tim2UB do not change when the |
+ ! | ^^^^^^^^ Variables are reassigned after the dynamical Initialization |
+ ! | (Reassignation => itexpe := nham => timar := timar-nham*dt) |
+ ! | |
+ ! | MODIF. 5 Nov 2009 : Map Scaling Factor SFm_DY scales (u,v) at UB |
+ ! | ^^^^^ (i.e., ua2_UB, va2_UB are divided by SFm_DY) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_ub
+
+ implicit none
+
+ integer ihamr_ubc, nhamr_ubc
+ integer newubcINI
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer(kind=8) itimUB
+ real rate
+
+ ! +--Current Time
+ ! + ============
+
+ itimUB = ou2sGE(iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, jsecGE)
+#if(HF)
+ itimUB = itimUB + (ihamr_ubc + nhamr_ubc) * idt
+#endif
+
+ ! +--Reinitialization of the Upper Sponge Reference State
+ ! + ----------------------------------------------------
+
+ if(iterun == 0) then
+ jdh_UB = 1
+ iyr_UB = iyrrGE
+ mma_UB = mmarGE
+ jda_UB = jdarGE
+ jhu_UB = jhurGE
+ tim1UB = itimUB
+ tim2UB = itimUB
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ ua1_UB(i, j, k) = uairUB(i, j, k)
+ ua2_UB(i, j, k) = uairUB(i, j, k)
+ va1_UB(i, j, k) = vairUB(i, j, k)
+ va2_UB(i, j, k) = vairUB(i, j, k)
+ pkt1UB(i, j, k) = pktaUB(i, j, k)
+ pkt2UB(i, j, k) = pktaUB(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ! +--New UBC
+ ! + =======
+
+ if(itimUB > tim2UB) then
+
+ tim1UB = tim2UB
+
+ write(6, 6001) jda_UB, labmGE(mma_UB), iyr_UB, &
+ jhu_UB, tim1UB, &
+ jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itimUB
+6001 format(/, ' 1st UBC /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/', 2x, &
+ ' t =', i12, 's A.P.', &
+ /, ' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12)
+ ! +
+ if(jdh_UB == 0) jdh_UB = -1
+ open(unit=11, status='old', form='unformatted', file='MARubc.DAT')
+ rewind 11
+11 continue
+ if(jdh_UB <= 0) go to 10
+
+ ! +--UBC at nesting time step n
+ ! + --------------------------
+
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ ua1_UB(i, j, k) = ua2_UB(i, j, k)
+ va1_UB(i, j, k) = va2_UB(i, j, k)
+ pkt1UB(i, j, k) = pkt2UB(i, j, k)
+ ua2_UB(i, j, k) = 0.d0
+ va2_UB(i, j, k) = 0.d0
+ pkt2UB(i, j, k) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ ! +--UBC at nesting time step n+1
+ ! + ----------------------------
+
+ read(11) iyr_UB, mma_UB, jda_UB, jhu_UB, jdh_UB
+ read(11) ua2_UB, va2_UB, pkt2UB
+
+ tim2UB = ou2sGE(iyr_UB, mma_UB, jda_UB, jhu_UB, 0, 0)
+
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ ua2_UB(i, j, k) = ua2_UB(i, j, k) / SFm_DY(i, j)
+ va2_UB(i, j, k) = va2_UB(i, j, k) / SFm_DY(i, j)
+ enddo
+ enddo
+ enddo
+
+ if(itimUB > tim2UB) go to 11
+
+ write(6, 6002) jda_UB, labmGE(mma_UB), iyr_UB, &
+ jhu_UB, jdh_UB, tim2UB
+6002 format(' 2nd UBC /', i3, '-', a3, '-', i4, i3, ' ', 2x, '/(', i1, &
+ ') t =', i12)
+
+10 continue
+ close(unit=11)
+
+ else
+#if(WR)
+ write(6, 6003) jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, itimUB
+6003 format(' Current /', i3, '-', a3, '-', i4, i3, ':', i2, ':', i2, &
+ ' t =', i12, 's A.P.')
+#endif
+ endif
+
+ ! +--Time Interpolation
+ ! + ==================
+
+ if(itimUB <= tim2UB .and. tim1UB < tim2UB) then
+
+ rate = float(itimUB - tim1UB) / float(tim2UB - tim1UB)
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ uairUB(i, j, k) = ua1_UB(i, j, k) + &
+ (ua2_UB(i, j, k) - ua1_UB(i, j, k)) * rate
+ vairUB(i, j, k) = va1_UB(i, j, k) + &
+ (va2_UB(i, j, k) - va1_UB(i, j, k)) * rate
+ pktaUB(i, j, k) = pkt1UB(i, j, k) + &
+ (pkt2UB(i, j, k) - pkt1UB(i, j, k)) * rate
+ enddo
+ enddo
+ enddo
+
+ newubcINI = 1
+
+ else
+ newubcINI = 0
+ endif
+
+ return
+end
diff --git a/MAR/code_mar/interp_subpix.f90 b/MAR/code_mar/interp_subpix.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d1ce98bdef9f5a6fad72adb07894ec113fd4a6b3
--- /dev/null
+++ b/MAR/code_mar/interp_subpix.f90
@@ -0,0 +1,189 @@
+#include "MAR_pp.def"
+subroutine interp_subpix(var, var_int, opt, inf, sup, grad_MS)
+ ! + ---------------------------------------------------------- +
+ ! / subroutine interp_subpix interpolates MAR variables /
+ ! / (inputs of SISVAT) on the subgrid. /
+ ! / Calculates a local gradient for the variable and adjusts /
+ ! / the subgrid values using the elevation difference between /
+ ! / the pixel and its subpixels. /
+ ! + ---------------------------------------------------------- +
+ ! / /
+ ! / INPUT : var : MAR variable to be interpolated /
+ ! / ^^^^^^^ /
+ ! / /
+ ! / OUTPUT : var_int : variable interpolated on the subgrid /
+ ! / ^^^^^^^ grad_MS : mean local gradient of var /
+ ! / (with spat. and temp. smoothing) /
+ ! + ---------------------------------------------------------- +
+ ! / /!\ opt = options /
+ ! / 1 = only interpolation (eg: for temperature) /
+ ! / 2 = interpolated value can not be negative /
+ ! / (eg: humidity, precipitation ...) /
+ ! / /
+ ! / inf, sup = lower and upper limits of the gradient /
+ ! / /
+ ! / dSH_min = min value of elevation difference between /
+ ! / 2 pixels to compute the local gradient = 100 m /
+ ! / /
+ ! / /
+ ! / Charlotte Lang 13/03/2015 /
+ ! + ---------------------------------------------------------- +
+
+ use mardim
+ use marctr
+ use mar_ge
+ use mar_sl
+ use margrd
+ use marssn
+
+ implicit none
+
+ integer i, j, k, m, n
+ real, parameter :: dSH_min = 100
+
+ real var(mx, my), var_int(mx, my, mw)
+ real delta_sh, delta_var, grad_old(mx, my)
+ real grad_var, grad_M(mx, my), grad_MS(mx, my)
+
+ ! + grad_var = gradient between the pixel and one of its 8 surrounding pixels
+ ! + grad_M = mean value of the local gradient. Average of the 8 surrounding gr
+ ! + grad_MS = mean gradient after spatial and temporal smoothing
+
+ real w, q, qi(-1:1, -1:1)
+ real inf, sup
+
+ integer opt
+ real sum_var_int(mx, my), fact(mx, my)
+
+ do i = 1, mx; do j = 1, my
+ do k = 1, nsx
+ var_int(i, j, k) = var(i, j)
+ if(isnan(var(i, j))) then
+ write(6, 399) iyrrGE, mmarGE, jdarGE, &
+ jhurGE, i, j
+399 format('/!\ CL WARNING: VAR is NaN ', i4, '/', i2, '/', &
+ i2, i3, 'h, (i,j)=', i4, i4)
+ stop
+ endif
+ enddo
+ enddo;
+ enddo
+
+ do i = 2, mx - 1; do j = 2, my - 1
+
+ if(itexpe == 0) grad_MS(i, j) = 0.0
+ grad_old(i, j) = grad_MS(i, j)
+
+ ! + grad_old = value of the mean local gradient at the previous time step. Used
+
+ ! + *******************************************
+ ! + *** Computing of the local gradient ***
+ ! + *******************************************
+
+ w = 0.0
+ grad_M(i, j) = 0.0
+
+ if(isolSL(i, j) >= 3) then ! Gradient is computed only for land pixels. gr
+
+ ! + Computation of the gradient between each pixel and its 8 surroung pixels (gr
+ do m = -1, 1; do n = -1, 1
+
+ grad_var = 0.0
+
+ if(isolSL(i + m, j + n) >= 3) then
+ delta_sh = sh(i + m, j + n) - sh(i, j)
+ if(abs(delta_sh) > dSH_min) then
+ ! + If no minimum elevation difference for the computation of the gradient, del
+ ! + to go through the if loop --> If dSH_min = 0.0, decomment next line.
+ ! if (delta_sh .neq. 0.0) then
+ delta_var = var(i + m, j + n) - var(i, j)
+ grad_var = delta_var / delta_sh
+ w = w + 1.0
+ endif
+ endif
+ ! + Computation of the mean local gradient
+ grad_M(i, j) = grad_M(i, j) + grad_var
+
+ enddo;
+ enddo
+
+ if(w /= 0.0) then ! w = # of pixels among the 8 surro
+ grad_M(i, j) = grad_M(i, j) / w ! If w = 0, no pixel among the 8 surrou
+ endif
+
+ if(isnan(grad_M(i, j))) then
+ write(6, 400) iyrrGE, mmarGE, jdarGE, &
+ jhurGE, i, j
+400 format('/!\ CL WARNING: grad is NaN ', i4, '/', i2, '/', &
+ i2, i3, 'h, (i,j)=', i4, i4)
+ stop
+ endif
+
+ endif
+ enddo;
+ enddo
+
+ !+ *** Smoothing of the mean local gradient ***
+ do i = 2, mx - 1; do j = 2, my - 1
+
+ q = 0.0
+ grad_MS(i, j) = 0.0
+
+ if(isolSL(i, j) >= 3) then
+
+ ! + *** Spatial smoothing of the gradient ***
+ do m = -1, 1; do n = -1, 1
+ if(isolSL(i + m, j + n) >= 3) then
+ qi(m, n) = 1.0
+ if(m == 0 .or. n == 0) qi(m, n) = 2.0
+ if(m == 0 .and. n == 0) qi(m, n) = 4.0
+ q = q + qi(m, n)
+ grad_MS(i, j) = grad_MS(i, j) + qi(m, n) * grad_M(i + m, j + n)
+ endif
+
+ enddo;
+ enddo
+
+ grad_MS(i, j) = grad_MS(i, j) / q
+
+ ! + *** Temporal smoothing of the gradient ***
+
+ if(itexpe /= 0) then
+ grad_MS(i, j) = 0.75 * grad_MS(i, j) + 0.25 * grad_old(i, j)
+ endif
+
+ ! + *** Lower and upper limits of the mean gradient value ***
+ grad_MS(i, j) = max(inf, min(sup, grad_MS(i, j)))
+
+ ! + ********************************************************
+ ! + *** Interpolation of the variable on the subgrid ***
+ ! + ********************************************************
+ do k = 1, nsx - 1
+ var_int(i, j, k) = var(i, j) &
+ + grad_MS(i, j) * (sh_int(i, j, k) - sh(i, j))
+ enddo
+
+ var_int(i, j, nsx) = var(i, j)
+
+ endif
+ enddo;
+ enddo
+
+ ! + *******************
+ ! + *** Options ***
+ ! + *******************
+
+ ! + Opt = 1 --> Nothing more than the interpolation is done
+ ! + Opt = 2 --> Interpolated value has to be positive
+
+ if(opt == 2) then
+ do i = 1, mx; do j = 1, my
+ do k = 1, nsx
+ var_int(i, j, k) = max(0.0, var_int(i, j, k))
+ enddo
+ enddo;
+ enddo
+ endif
+
+ return
+endsubroutine interp_subpix
diff --git a/MAR/code_mar/lbcnud_000.f90 b/MAR/code_mar/lbcnud_000.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2cbcc70fda8d4e1ef44a00e2a3cc90bb379a5f51
--- /dev/null
+++ b/MAR/code_mar/lbcnud_000.f90
@@ -0,0 +1,267 @@
+#include "MAR_pp.def"
+subroutine LBCnud_000(f_LBC0, iv_nu0, kd_nu0)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS LBC 29-01-2020 MAR |
+ ! | subroutine LBCnud_000 computes the Lateral Boundary Conditions |
+ ! | following the Davies (1976) scheme |
+ ! | assuming zero Outer Fields |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT / OUTPUT : f_LBC0, i.e. w,pairNH, ccniHY, qi,qs,qr,qwHY |
+ ! | ^^^^^^^^ for iv_nu0 = 3, 3, 3, 3, 3, 3) |
+ ! | f_LBC0 reevalued on a 5-points width boundary zone |
+ ! | |
+ ! | INPUT: iv_nu0: Index of the Variable to relax to Outer Conditions |
+ ! | ^^^^^^ kd_nu0: Maximum Value of the k (vertical) Index |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ reaLBC: Input INI: Previous Dyn.Simulation (MAR .or. GCM) |
+ ! | rxfact: Lateral Sponge Coefficient (A89) |
+ ! | rxLB,ryLB: Nudging Coefficient |
+ ! | Independant Term used in the Implicit Scheme |
+ ! | |
+ ! | REFER. : Davies, QJRMS 102, pp.405--418, 1976 (relation 11 p.409) |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_lb
+ use mar_wk
+
+ implicit none
+
+ ! Global Variables
+ ! ================
+
+ real f_LBC0(mx, my, mz)
+ integer iv_nu0, kd_nu0
+
+ ! Local Variables
+ ! ================
+
+ integer i, j, k, m
+ logical relaxg
+
+ ! fmag0X:magnification factor (=>nudging selectively modified)
+ real fmag0g(6), fmag0d(6), fmag0b(6), fmag0h(6)
+ data fmag0g/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ data fmag0d/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ data fmag0b/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ data fmag0h/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+#if(OG)
+ ! relaxg=.false.==> NO nudging at the left boundary.
+ data relaxg/.false./
+#endif
+
+ ! x Boundaries
+ ! ============
+
+!$OMP PARALLEL do default(shared) private(i,j,k)
+ do k = 1, kd_nu0
+
+ if(mmx > 1) then
+
+#if(OG)
+ if(relaxg) then
+#endif
+ do i = ip11, n6 - 1
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(i, j, k) = f_LBC0(i, j, k) &
+ / (1.0 + fmag0g(iv_nu0) * rxLB(i))
+ enddo
+ ! end do
+ enddo
+#if(OG)
+ endif
+#endif
+
+ do i = mx - n6 + 2, mx1
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(i, j, k) = f_LBC0(i, j, k) &
+ / (1.0 + fmag0d(iv_nu0) * rxLB(i))
+ enddo
+ ! end do
+ enddo
+
+ ! Zero Gradient at x LBC if fmag0g,d = 0
+ ! --------------------------------------
+
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(1, j, k) = (1.-fmag0g(iv_nu0)) * f_LBC0(ip11, j, k) ! 0-grad.
+ ! . + fmag0g(iv_nu0) *f_LBC0( 1,j,k) ! 0 at x-LB
+ f_LBC0(mx, j, k) = (1.-fmag0d(iv_nu0)) * f_LBC0(mx1, j, k) ! 0-grad.
+ ! . + fmag0d(iv_nu0) *f_LBC0( mx ,j,k) ! 0 at x-LB
+ enddo
+ ! end do
+
+ ! Nudging to zero in in the lateral Sponge
+ ! ----------------------------------------
+
+ do i = ip11, n6 - 1
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ WKxyz1(i, j, k) = f_LBC0(i, j, k) + rxfact * rxLB(i) &
+ * (f_LBC0(i + 1, j, k) + f_LBC0(i - 1, j, k) &
+ - f_LBC0(i, j, k) - f_LBC0(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ do i = ip11, n6 - 1
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(i, j, k) = WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ do i = mx - n6 + 2, mx1
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ WKxyz1(i, j, k) = f_LBC0(i, j, k) + rxfact * rxLB(i) &
+ * (f_LBC0(i + 1, j, k) + f_LBC0(i - 1, j, k) &
+ - f_LBC0(i, j, k) - f_LBC0(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ do i = mx - n6 + 2, mx1
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(i, j, k) = WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! Zero Gradient at x LBC if fmag0g,d = 0
+ ! --------------------------------------
+
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(1, j, k) = (1.-fmag0g(iv_nu0)) * f_LBC0(ip11, j, k) ! 0-grad.
+ ! . + fmag0g(iv_nu0) *f_LBC0( 1,j,k) ! 0 at x-LB
+ f_LBC0(mx, j, k) = (1.-fmag0d(iv_nu0)) * f_LBC0(mx1, j, k) ! 0-grad.
+ ! . + fmag0d(iv_nu0) *f_LBC0( mx ,j,k) ! 0 at x-LB
+ enddo
+ ! end do
+
+ endif
+
+ ! y Boundaries
+ ! ============
+
+ if(mmy > 1) then
+
+ do j = jp11, n6 - 1
+ ! do k= 1 ,kd_nu0
+ do i = 1, mx
+ f_LBC0(i, j, k) = f_LBC0(i, j, k) &
+ / (1.0 + fmag0b(iv_nu0) * ryLB(j))
+ enddo
+ ! end do
+ enddo
+
+ do j = my - n6 + 2, my1
+ ! do k= 1 ,kd_nu0
+ do i = 1, mx
+ f_LBC0(i, j, k) = f_LBC0(i, j, k) &
+ / (1.0 + fmag0h(iv_nu0) * ryLB(j))
+ enddo
+ ! end do
+ enddo
+
+ ! Zero Gradient at y LBC if fmag0b,h = 0
+ ! --------------------------------------
+
+ ! do k= 1 ,kd_nu0
+ do i = 1, mx
+ f_LBC0(i, 1, k) = (1.-fmag0b(iv_nu0)) * f_LBC0(i, jp11, k) ! 0-grad.
+ ! . + fmag0b(iv_nu0) *f_LBC0(i, 1,k) ! 0 at y-LB
+ f_LBC0(i, my, k) = (1.-fmag0h(iv_nu0)) * f_LBC0(i, my1, k) ! 0-grad.
+ ! . + fmag0h(iv_nu0) *f_LBC0(i, my ,k) ! 0 at y-LB
+ enddo
+ ! end do
+
+ ! Nudging to zero in in the lateral Sponge
+ ! ----------------------------------------
+
+ do j = 2, n6 - 1
+ ! do k= 1 ,kd_nu0
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = f_LBC0(i, j, k) + rxfact * ryLB(j) &
+ * (f_LBC0(i, j + 1, k) + f_LBC0(i, j - 1, k) &
+ - f_LBC0(i, j, k) - f_LBC0(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ do j = 2, n6 - 1
+ ! do k= 1 ,kd_nu0
+ do i = ip11, mx1
+ f_LBC0(i, j, k) = WKxyz2(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ do j = my - n6 + 2, my1
+ ! do k= 1 ,kd_nu0
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = f_LBC0(i, j, k) + rxfact * ryLB(j) &
+ * (f_LBC0(i, j + 1, k) + f_LBC0(i, j - 1, k) &
+ - f_LBC0(i, j, k) - f_LBC0(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ do j = my - n6 + 2, my1
+ ! do k= 1 ,kd_nu0
+ do i = ip11, mx1
+ f_LBC0(i, j, k) = WKxyz2(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! Zero Gradient at y LBC if fmag0b,h = 0
+ ! --------------------------------------
+
+ ! do k= 1 ,kd_nu0
+ do j = jp11, my1
+ f_LBC0(i, 1, k) = (1.-fmag0b(iv_nu0)) * f_LBC0(i, jp11, k) ! 0-grad.
+ ! . + fmag0b(iv_nu0) *f_LBC0(i, 1,k) ! 0 at y-LB
+ f_LBC0(i, my, k) = (1.-fmag0h(iv_nu0)) * f_LBC0(i, my1, k) ! 0-grad.
+ ! . + fmag0h(iv_nu0) *f_LBC0(i, my ,k) ! 0 at y-LB
+ enddo
+ ! end do
+
+#if(OB)
+ do k = 1, kd_nu0
+ f_LBC0(1, 1, k) = (f_LBC0(1, jp11, k) + f_LBC0(ip11, 1, k)) * 0.5
+ f_LBC0(mx, 1, k) = (f_LBC0(mx, jp11, k) + f_LBC0(mx1, 1, k)) * 0.5
+ f_LBC0(1, my, k) = (f_LBC0(1, my1, k) + f_LBC0(ip11, my, k)) * 0.5
+ f_LBC0(mx, my, k) = (f_LBC0(mx, my1, k) + f_LBC0(mx1, my, k)) * 0.5
+ enddo
+#endif
+
+ endif
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+ return
+endsubroutine LBCnud_000
diff --git a/MAR/code_mar/lbcnud_atm.f90 b/MAR/code_mar/lbcnud_atm.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5a047e45ad18c73dbe628c7d692040130f5d648e
--- /dev/null
+++ b/MAR/code_mar/lbcnud_atm.f90
@@ -0,0 +1,374 @@
+#include "MAR_pp.def"
+subroutine LBCnud_atm(f__LBC, iv_nua, kd_nua)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS LBC Fri 4-12-2009 MAR |
+ ! | subroutine LBCnud_atm computes the Lateral Boundary Conditions |
+ ! | following the Davies (1976) scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT / OUTPUT : f__LBC, i.e. uairDY, vairDY, qvDY, pktaDY, pstDYn |
+ ! | ^^^^^^^^ for iv_nua = 1, 2, 3, 4, 5 |
+ ! | f_LBC0 reevalued on a 5-points width boundary zone |
+ ! | |
+ ! | INPUT: iv_nua: Index of the Variable to relax to Outer Conditions |
+ ! | ^^^^^^ kd_nua: Maximum Value of the k (vertical) Index |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ reaLBC: Input INI: Previous Dyn.Simulation (MAR .or. GCM) |
+ ! | rxfact: Lateral Sponge Coefficient (A89) |
+ ! | rxLB,ryLB: Nudging Coefficient |
+ ! | Independant Term used in the Implicit Scheme |
+ ! | |
+ ! | REFER. : Davies, QJRMS 102, pp.405--418, 1976 (relation 11 p.409) |
+ ! | ^^^^^^^^ |
+ ! | |
+ ! | INPUT : Nudging Coefficient rxLB and ryLB |
+ ! | ^^^^^^^^ Inverted Matrices used in the Implicit Scheme |
+ ! | wixgLB (zone x <<), wixdLB (zone x >>) |
+ ! | wiyiLB (zone y <<), wiysLB (zone y >>) |
+ ! | Independant Term used in the Implicit Scheme |
+ ! | Variable v: tixgLB (zone x <<), tixdLB (zone x >>) |
+ ! | Variable u: tiyiLB (zone y <<), tiysLB (zone y >>) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_lb
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ real f__LBC(mx, my, mz)
+ integer kd_nua, iv_nua
+
+ ! +--Local Variables
+ ! + ================
+
+#if(OG)
+ logical relaxg
+#endif
+
+ integer il, ic, jl, jc
+ real sx(mx, mz)
+ real sy(my, mz)
+ real txg(2:n7, mz), txd(mx - n6:mx1, mz)
+ real tyi(2:n7, mz), tys(my - n6:my1, mz)
+
+ real fmagng(6), fmagnd(6), fmagnb(6), fmagnh(6)
+
+ data fmagng/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ data fmagnd/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ data fmagnb/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ data fmagnh/1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0, 1.0e0/
+ ! +... fmagnX:magnification factor (=>nudging selectively modified)
+
+#if(OG)
+ ! relaxg=.false.==> NO nudging at the left boundary.
+ data relaxg/.false./
+#endif
+
+ ! x Boundaries
+ ! ============
+!$OMP PARALLEL do default(shared) private(i,j,k,il,ic)
+ do k = 1, kd_nua
+ if(mmx > 1) then
+ if(iv_nua == 2) then
+ ! +
+ do j = jp11, my1
+ ! +--`Left' Boundary (x <<)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do il = ip11, n7
+ ! do k = 1,kd_nua
+ txg(il, k) = 0.d0
+ ! end do
+ do ic = ip11, n7
+ ! do k = 1,kd_nua
+ txg(il, k) = txg(il, k) &
+ + (tixgLB(ic, j, k) &
+ + f__LBC(ic, j, k)) * wixgLB(il, ic)
+ ! end do
+ enddo
+ enddo
+ do i = ip11, n7
+ ! do k = 1,kd_nua
+ f__LBC(i, j, k) = txg(i, k)
+ ! end do
+ enddo
+
+ ! +--`Right' Boundary (x >>)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ do il = mx - n6, mx1
+ ! do k = 1,kd_nua
+ txd(il, k) = 0.d0
+ ! end do
+ do ic = mx - n6, mx1
+ ! do k = 1,kd_nua
+ txd(il, k) = txd(il, k) + &
+ (tixdLB(ic, j, k) &
+ + f__LBC(ic, j, k)) * wixdLB(il, ic)
+ ! end do
+ enddo
+ enddo
+ do i = mx - n6mxLB, mx1
+ ! do k = 1,kd_nua
+ f__LBC(i, j, k) = txd(i, k)
+ ! end do
+ enddo
+ enddo
+
+ else
+ do j = jp11, my1
+#if(OG)
+ if(relaxg) then
+#endif
+ do i = ip11, n6 - 1
+ ! do k = 1,kd_nua
+ f__LBC(i, j, k) = (f__LBC(i, j, k) &
+ + fmagng(iv_nua) * rxLB(i) * vaxgLB(i, j, k, iv_nua)) &
+ / (1.d0 + fmagng(iv_nua) * rxLB(i))
+ ! end do
+ enddo
+#if(OG)
+ endif
+#endif
+ do i = mx - n6 + 2, mx1
+ ! do k = 1,kd_nua
+ f__LBC(i, j, k) = (f__LBC(i, j, k) &
+ + fmagnd(iv_nua) * rxLB(i) * vaxdLB(i, j, k, iv_nua)) &
+ / (1.d0 + fmagnd(iv_nua) * rxLB(i))
+ ! end do
+ enddo
+ enddo
+ endif
+
+ ! Zero Gradient at y LBC if fmagng,d = 0 / otherwise prescribed LBC
+ ! -----------------------------------------------------------------
+ ! do k=1,kd_nua
+ do j = 1, my
+ f__LBC(1, j, k) = &
+ (1.-fmagng(iv_nua)) * f__LBC(ip11, j, k) &
+ + fmagng(iv_nua) * vaxgLB(1, j, k, iv_nua)
+ f__LBC(mx, j, k) = &
+ (1.-fmagnd(iv_nua)) * f__LBC(mx1, j, k) &
+ + fmagnd(iv_nua) * vaxdLB(mx, j, k, iv_nua)
+ enddo
+ ! end do
+
+ ! Nudging
+ ! -------
+ do i = ip11, n6 - 1
+ ! do k= 1,kd_nua
+ do j = jp11, my1
+ WKxyz1(i, j, k) = f__LBC(i, j, k) + rxfact * rxLB(i) &
+ * (f__LBC(i + 1, j, k) + f__LBC(i - 1, j, k) &
+ - f__LBC(i, j, k) - f__LBC(i, j, k) &
+ - vaxgLB(i + 1, j, k, iv_nua) - vaxgLB(i - 1, j, k, iv_nua) &
+ + vaxgLB(i, j, k, iv_nua) + vaxgLB(i, j, k, iv_nua))
+ enddo
+ ! end do
+ enddo
+ do i = ip11, n6 - 1
+ ! do k= 1,kd_nua
+ do j = jp11, my1
+ f__LBC(i, j, k) = WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ do i = mx - n6 + 2, mx1
+ ! do k= 1 ,kd_nua
+ do j = jp11, my1
+ WKxyz1(i, j, k) = f__LBC(i, j, k) + rxfact * rxLB(i) &
+ * (f__LBC(i + 1, j, k) + f__LBC(i - 1, j, k) &
+ - f__LBC(i, j, k) - f__LBC(i, j, k) &
+ - vaxdLB(i + 1, j, k, iv_nua) - vaxdLB(i - 1, j, k, iv_nua) &
+ + vaxdLB(i, j, k, iv_nua) + vaxdLB(i, j, k, iv_nua))
+ enddo
+ ! end do
+ enddo
+ do i = mx - n6 + 2, mx1
+ ! do k= 1 ,kd_nua
+ do j = jp11, my1
+ f__LBC(i, j, k) = WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! Zero Gradient at y LBC if fmagng,d = 0 / otherwise prescribed LBC
+ ! -----------------------------------------------------------------
+ ! do k=1,kd_nua
+ do j = jp11, my1
+ f__LBC(1, j, k) = &
+ (1.-fmagng(iv_nua)) * f__LBC(ip11, j, k) &
+ + fmagng(iv_nua) * vaxgLB(1, j, k, iv_nua)
+ f__LBC(mx, j, k) = &
+ (1.-fmagnd(iv_nua)) * f__LBC(mx1, j, k) &
+ + fmagnd(iv_nua) * vaxdLB(mx, j, k, iv_nua)
+ enddo
+ ! end do
+ endif
+
+ ! y Boundaries
+ ! ============
+ if(mmy > 1) then
+ if(iv_nua == 1) then
+ do i = 1, mx
+ ! +--`Bottom' Boundary (y <<)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~
+ do jl = jp11, n7
+ ! do k = 1,kd_nua
+ tyi(jl, k) = 0.d0
+ ! end do
+ do jc = jp11, n7
+ ! do k = 1,kd_nua
+ tyi(jl, k) = tyi(jl, k) &
+ + (tiyiLB(i, jc, k) &
+ + f__LBC(i, jc, k)) * wiyiLB(jl, jc)
+ ! end do
+ enddo
+ enddo
+ do j = jp11, n7
+ ! do k = 1,kd_nua
+ f__LBC(i, j, k) = tyi(j, k)
+ ! end do
+ enddo
+ ! +--`Top' Boundary (y >>)
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ do jl = my - n6, my - 1
+ ! do k = 1,kd_nua
+ tys(jl, k) = 0.d0
+ ! end do
+ do jc = my - n6, my - 1
+ ! do k = 1,kd_nua
+ tys(jl, k) = tys(jl, k) &
+ + (tiysLB(i, jc, k) &
+ + f__LBC(i, jc, k)) * wiysLB(jl, jc)
+ ! end do
+ enddo
+ enddo
+ do j = my - n6, my - 1
+ ! do k = 1,kd_nua
+ f__LBC(i, j, k) = tys(j, k)
+ ! end do
+ enddo
+ enddo
+ else
+ do j = jp11, n6 - 1
+ ! do k= 1 ,kd_nua
+ do i = 1, mx
+ f__LBC(i, j, k) = (f__LBC(i, j, k) &
+ + fmagnb(iv_nua) * ryLB(j) * vayiLB(i, j, k, iv_nua)) &
+ / (1.d0 + fmagnb(iv_nua) * ryLB(j))
+ enddo
+ ! end do
+ enddo
+ do j = my - n6 + 2, my1
+ ! do k= 1 ,kd_nua
+ do i = 1, mx
+ f__LBC(i, j, k) = (f__LBC(i, j, k) &
+ + fmagnh(iv_nua) * ryLB(j) * vaysLB(i, j, k, iv_nua)) &
+ / (1.d0 + fmagnh(iv_nua) * ryLB(j))
+ enddo
+ ! end do
+ enddo
+ endif
+
+ ! Zero Gradient at y LBC if fmagnb,h = 0 / otherwise prescribed LBC
+ ! -----------------------------------------------------------------
+ ! do k=1,kd_nua
+ do i = 1, mx
+ f__LBC(i, 1, k) = &
+ (1.-fmagnb(iv_nua)) * f__LBC(i, jp11, k) &
+ + fmagnb(iv_nua) * vayiLB(i, 1, k, iv_nua)
+ f__LBC(i, my, k) = &
+ (1.-fmagnh(iv_nua)) * f__LBC(i, my1, k) &
+ + fmagnh(iv_nua) * vaysLB(i, my, k, iv_nua)
+ enddo
+ ! end do
+
+ ! Nudging
+ ! -------
+ do j = 2, n6 - 1
+ ! do k=1 ,kd_nua
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = f__LBC(i, j, k) + rxfact * ryLB(j) &
+ * (f__LBC(i, j + 1, k) + f__LBC(i, j - 1, k) &
+ - f__LBC(i, j, k) - f__LBC(i, j, k) &
+ - vayiLB(i, j + 1, k, iv_nua) - vayiLB(i, j - 1, k, iv_nua) &
+ + vayiLB(i, j, k, iv_nua) + vayiLB(i, j, k, iv_nua))
+ enddo
+ ! end do
+ enddo
+ do j = 2, n6 - 1
+ ! do k=1 ,kd_nua
+ do i = ip11, mx1
+ f__LBC(i, j, k) = WKxyz2(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ do j = my - n6 + 2, my1
+ ! do k=1 ,kd_nua
+ do i = ip11, mx1
+ WKxyz2(i, j, k) = f__LBC(i, j, k) + rxfact * ryLB(j) &
+ * (f__LBC(i, j + 1, k) + f__LBC(i, j - 1, k) &
+ - f__LBC(i, j, k) - f__LBC(i, j, k) &
+ - vaysLB(i, j + 1, k, iv_nua) - vaysLB(i, j - 1, k, iv_nua) &
+ + vaysLB(i, j, k, iv_nua) + vaysLB(i, j, k, iv_nua))
+ enddo
+ ! end do
+ enddo
+ do j = my - n6 + 2, my1
+ ! do k=1 ,kd_nua
+ do i = ip11, mx1
+ f__LBC(i, j, k) = WKxyz2(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! Zero Gradient at y LBC if fmagnb,h = 0 / otherwise prescribed LBC
+ ! -----------------------------------------------------------------
+ ! do k=1,kd_nua
+ do i = ip11, mx1
+ f__LBC(i, 1, k) = &
+ (1.-fmagnb(iv_nua)) * f__LBC(i, jp11, k) &
+ + fmagnb(iv_nua) * vayiLB(i, 1, k, iv_nua)
+ f__LBC(i, my, k) = &
+ (1.-fmagnh(iv_nua)) * f__LBC(i, my1, k) &
+ + fmagnh(iv_nua) * vaysLB(i, my, k, iv_nua)
+ enddo
+ ! end do
+
+#if(OB)
+ do k = 1, kd_nua
+ f__LBC(1, 1, k) = (f__LBC(1, jp11, k) &
+ + f__LBC(ip11, 1, k)) * 0.5d0
+ f__LBC(mx, 1, k) = (f__LBC(mx, jp11, k) &
+ + f__LBC(mx1, 1, k)) * 0.5d0
+ f__LBC(1, my, k) = (f__LBC(1, my1, k) &
+ + f__LBC(ip11, my, k)) * 0.5d0
+ f__LBC(mx, my, k) = (f__LBC(mx, my1, k) &
+ + f__LBC(mx1, my, k)) * 0.5d0
+ enddo
+#endif
+ endif
+
+ ! Work Arrays Reset
+ ! =================
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+ return
+endsubroutine LBCnud_atm
diff --git a/MAR/code_mar/lbcnud_ini.f90 b/MAR/code_mar/lbcnud_ini.f90
new file mode 100644
index 0000000000000000000000000000000000000000..160793d876bdfdc8b8465fd2a923a9053b1b4c52
--- /dev/null
+++ b/MAR/code_mar/lbcnud_ini.f90
@@ -0,0 +1,72 @@
+#include "MAR_pp.def"
+subroutine lbcnud_ini
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS LBC 18-09-2001 MAR |
+ ! | subroutine lbcnud_ini initialize the Nudging Coefficient |
+ ! | for the lateral boundary conditions of Davies, 1983 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | REFER. : Davies, MWR 111, p.1002-1012, 1983 |
+ ! | ^^^^^^^^ |
+ ! | |
+ ! | OUTPUT : rxLB,ryLB: nudging coefficients of the relaxation zones |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_lb
+ use mar_io
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ real d25
+#if(da)
+ real cspeed
+ ! +--Nudging Coefficient Multiplied by the Time Step
+ ! + ===============================================
+ cspeed = 300.d0 * max(n6 - 1, 1) * max(n6 - 1, 1) &
+ / (max(n6 - 2, 1) * max(n6 - 2, 1))
+ ! rxbase: Optimal Maximum Relaxation Coefficient
+ ! (see Davies 1983, MWR 111 p. 1007, 2e col. K* = K(dx)/c,
+ ! with K*~0.5, c= c_max= sqrt(gH)=300m/s)
+ rxbase = cspeed / (2.d0 * dx)
+ ! rxfact: Such that nu* < 1, but Diffusion_Relaxation replaces Diffusion
+ ! (see Davies 1983, MWR 111 p. 1004, 1e col. nu* = K(dx)/c,
+ ! p. 1007, 1e col. 21b)
+ rxfact = 0.5 * dt * max(n6 - 1, 1) * max(n6 - 1, 1) &
+ / (max(n6 - 2, 1) * max(n6 - 2, 1))
+#endif
+ if(IO_loc >= 2) write(21, 999) rxbase, rxfact
+999 format(/, ' --- Initialisation / lbcnud_ini ---', &
+ /, ' K(relax)max =', f14.6, ' (Davies 1983 MWR)', &
+ /, ' K_H(fac) =', f14.6)
+ ! +
+ d25 = (n6 - 1) * (n6 - 1)
+ rxLB(1) = 0.d0
+ rxLB(mx) = 0.d0
+ if(mmx > 1) then
+ do i = ip11, mx1
+ rxLB(i) = (max(0, n6 - i) * max(0, n6 - i) &
+ + max(0, n6 - 1 + i - mx) * max(0, n6 - 1 + i - mx)) &
+ * rxbase / d25
+ enddo
+ endif
+ ! +
+ ryLB(1) = 0.d0
+ ryLB(my) = 0.d0
+ if(mmy > 1) then
+ do j = jp11, my1
+ ryLB(j) = (max(0, n6 - j) * max(0, n6 - j) &
+ + max(0, n6 - 1 + j - my) * max(0, n6 - 1 + j - my)) &
+ * rxbase / d25
+ enddo
+ endif
+ ! +
+ return
+endsubroutine lbcnud_ini
diff --git a/MAR/code_mar/lbcnud_par.f90 b/MAR/code_mar/lbcnud_par.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3b32e713de60fa693ca09850d99a619683d62b1b
--- /dev/null
+++ b/MAR/code_mar/lbcnud_par.f90
@@ -0,0 +1,319 @@
+#include "MAR_pp.def"
+subroutine lbcnud_par
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS LBC 26-09-2001 MAR |
+ ! | subroutine lbcnud_par initialize the implicit numerical scheme |
+ ! | for LBC on Wind Component parallel to the Boundary |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | REFER. : Davies, QJRMS 102, pp.405--418, 1976 |
+ ! | ^^^^^^^^ |
+ ! | |
+ ! | INPUT : vaXX : large scale values of relevant dependant variables |
+ ! | ^^^^^^^^ ^X=(x->x axis border, y->y axis border) |
+ ! | ^X=(g->x small, d->x large, b->y small, h->y large) |
+ ! | |
+ ! | OUTPUT : wiXX : coefficient used in semi-implicit numerical scheme |
+ ! | ^^^^^^^^ tiXX : independant term of semi-implicit numerical scheme |
+ ! | ^X=(x->x axis border--variable v, |
+ ! | y->y axis border--variable u) |
+ ! | ^X=(g->x small, d->x large, b->y small, h->y large) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_lb
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ integer il, ic, ii, nn, n2, n3, n4, lmin, lmax, jl, jc, iv_nup, n1
+ real wkxd(mx - n6:mx1, mx - n6:mx1)
+
+ ! +--Matrix Inversion for x large (Reference Boundary)
+ ! + =================================================
+ ! +
+ if(iterun == 0) then
+ ! +
+ if(mmx > 1) then
+ ! +
+ do il = mx - n6, mx1
+ do ic = mx - n6, mx1
+ wkxd(il, ic) = 0.d0
+ enddo
+ enddo
+ ! +
+ do ii = mx - n6, mmx2
+ wkxd(ii, ii + 1) = rxLB(ii + 1) - rxLB(ii)
+ enddo
+ do ii = mx - n6, mmx1
+ wkxd(ii, ii) = 1 + 2 * rxLB(ii) + rxLB(ii + 1) - rxLB(ii - 1)
+ enddo
+#if(OB)
+ wkxd(mx1, mx1) = 1 + rxLB(mx) - rxLB(mmx2)
+#endif
+ do ii = mx - n6 + 1, mmx1
+ wkxd(ii, ii - 1) = rxLB(ii)
+ enddo
+ do nn = 1, n6 - 3
+ n2 = nn + 1
+ n3 = nn + 2
+ n4 = n6 - 1 - nn
+ do ii = mx - n4, mmx1
+ wkxd(ii, ii - n2) = rxLB(ii - nn) - rxLB(ii - n3)
+ enddo
+ enddo
+ ! +
+ wkxd(mx1, mx - n6) = rxLB(mmx5)
+ ! +
+ lmin = mx - n6
+ lmax = mx1
+ ! +
+ ! + ******
+ call matinv(wkxd, wixdLB, lmin, lmax)
+ ! + ******
+ ! +
+ ! +--Inverted Matrices at Other Boundaries
+ ! + =====================================
+ ! +
+ do il = 2, n7
+ do ic = 2, n7
+ wixgLB(il, ic) = wixdLB(mx + 1 - il, mx + 1 - ic)
+ enddo
+ enddo
+ ! +... x small
+ ! +
+ endif
+ ! +
+ if(mmy > 1) then
+ ! +
+ do jl = 2, n7
+ do jc = 2, n7
+ wiyiLB(jl, jc) = wixgLB(jl, jc)
+ enddo
+ enddo
+ ! +... y small
+ ! +
+ do jl = 2, n7
+ do jc = 2, n7
+ wiysLB(my + 1 - jl, my + 1 - jc) = wiyiLB(jl, jc)
+ enddo
+ enddo
+ ! +... y large
+ ! +
+ endif
+ endif
+ ! +
+ ! +
+ ! +--Independant Terms (Constant Coefficients)
+ ! + =========================================
+ ! +
+ ! +--x Boundaries
+ ! + ------------
+ ! +
+ if(mmx > 1) then
+ ! +
+ iv_nup = 2
+ do k = 1, mz
+ do j = 1, my
+ ! +
+ ! +--x large
+ ! + ~~~~~~~
+ do i = mx - n6, mmx1
+ tixdLB(i, j, k) = rxLB(n50xLB) * vaxdLB(mx - n6, j, k, iv_nup)
+ enddo
+ do i = mx - n6, mmx2
+ tixdLB(i, j, k) = tixdLB(i, j, k) + (rxLB(i + 1) &
+ - rxLB(i)) * vaxdLB(i + 1, j, k, iv_nup)
+ enddo
+ do i = mx - n6 + 1, mmx2
+ tixdLB(i, j, k) = tixdLB(i, j, k) + (2 * rxLB(i) + rxLB(i + 1) &
+ - rxLB(i - 1)) * vaxdLB(i, j, k, iv_nup)
+ enddo
+ do i = mx - n6 + 2, mmx1
+ tixdLB(i, j, k) = tixdLB(i, j, k) &
+ + rxLB(n40xLB) * vaxdLB(n50xLB, j, k, iv_nup)
+ enddo
+ ! +
+ do nn = n6 - 4, n6 - 3
+ n1 = nn + 1
+ n2 = nn + 2
+ do i = mx - nn, mmx1
+ tixdLB(i, j, k) = tixdLB(i, j, k) &
+ + (rxLB(mx - nn) - rxLB(mx - n2)) * &
+ vaxdLB(mx - n1, j, k, iv_nup)
+ enddo
+ enddo
+ ! +
+#if(OB)
+ if(openLB) then
+ tixdLB(mx1, j, k) = tixdLB(mx1, j, k) &
+ + (rxLB(mmx1) - rxLB(mmx3)) * &
+ vaxdLB(mmx2, j, k, iv_nup) &
+ + 3 * rxLB(mmx1) * vaxdLB(mmx1, j, k, iv_nup)
+ else
+#endif
+ tixdLB(mx1, j, k) = tixdLB(mx1, j, k) &
+ + (rxLB(mmx1) - rxLB(mmx3)) * &
+ vaxdLB(mmx2, j, k, iv_nup) &
+ + 2 * rxLB(mmx1) * vaxdLB(mmx1, j, k, iv_nup)
+#if(OB)
+ endif
+#endif
+ ! +
+ ! +--x small
+ ! + ~~~~~~~
+ do i = n7mxLB, 2, -1
+ tixgLB(i, j, k) = rxLB(n6mxLB) * &
+ vaxgLB(n7mxLB, j, k, iv_nup)
+ enddo
+ do i = n7mxLB, 3, -1
+ tixgLB(i, j, k) = tixgLB(i, j, k) + (rxLB(i - 1) &
+ - rxLB(i)) * vaxgLB(i - 1, j, k, iv_nup)
+ enddo
+ do i = n6, 3, -1
+ tixgLB(i, j, k) = tixgLB(i, j, k) + &
+ (2 * rxLB(i) + rxLB(i - 1) &
+ - rxLB(i + 1)) * vaxgLB(i, j, k, iv_nup)
+ enddo
+ do i = n6 - 1, 2, -1
+ tixgLB(i, j, k) = tixgLB(i, j, k) &
+ + rxLB(n5mxLB) * vaxgLB(n6mxLB, j, k, iv_nup)
+ enddo
+ ! +
+ do nn = n6 - 3, n6 - 2
+ n1 = nn + 1
+ n2 = nn + 2
+ do i = nn, 2, -1
+ tixgLB(i, j, k) = tixgLB(i, j, k) &
+ + (rxLB(nn) - rxLB(n2)) * &
+ vaxgLB(n1, j, k, iv_nup)
+ enddo
+ enddo
+ ! +
+#if(OB)
+ if(openLB) then
+ tixgLB(2, j, k) = tixgLB(2, j, k) &
+ + (rxLB(m0x2) - rxLB(m0x4)) * &
+ vaxgLB(m0x3, j, k, iv_nup) + &
+ 3 * rxLB(m0x2) * vaxgLB(m0x2, j, k, iv_nup)
+ else
+#endif
+ tixgLB(2, j, k) = tixgLB(2, j, k) + &
+ (rxLB(m0x2) - rxLB(m0x4)) * &
+ vaxgLB(m0x3, j, k, iv_nup) + &
+ 2 * rxLB(m0x2) * vaxgLB(m0x2, j, k, iv_nup)
+#if(OB)
+ endif
+#endif
+ enddo
+ ! +
+ enddo
+ ! +
+ endif
+ ! +
+ ! +
+ ! +--y Boundaries
+ ! + ------------
+ ! +
+ if(mmy > 1) then
+ ! +
+ iv_nup = 1
+ do k = 1, mz
+ do i = 1, mx
+ ! +
+ ! +--y large
+ ! + ~~~~~~~
+ do j = my - n6, mmy1
+ tiysLB(i, j, k) = ryLB(n50yLB) &
+ * vaysLB(i, my - n6myLB, k, iv_nup)
+ enddo
+ do j = my - n6, mmy2
+ tiysLB(i, j, k) = tiysLB(i, j, k) + (ryLB(j + 1) &
+ - ryLB(j)) * vaysLB(i, j + 1, k, iv_nup)
+ enddo
+ do j = my - n6 + 1, mmy2
+ tiysLB(i, j, k) = tiysLB(i, j, k) + (2 * ryLB(j) + ryLB(j + 1) &
+ - ryLB(j - 1)) * vaysLB(i, j, k, iv_nup)
+ enddo
+ do j = my - n6 + 2, mmy1
+ tiysLB(i, j, k) = tiysLB(i, j, k) &
+ + ryLB(n40yLB) * vaysLB(i, my - n6 + 1, k, iv_nup)
+ enddo
+ ! +
+ do nn = n6 - 4, n6 - 3
+ n1 = nn + 1
+ n2 = nn + 2
+ do j = my - 3, mmy1
+ tiysLB(i, j, k) = tiysLB(i, j, k) &
+ + (ryLB(my - nn) - ryLB(my - n2)) * vaysLB(i, my - n1, k, iv_nup)
+ enddo
+ enddo
+ ! +
+#if(OB)
+ if(openLB) then
+ tiysLB(i, my1, k) = tiysLB(i, my1, k) &
+ + (ryLB(mmy1) - ryLB(mmy3)) * vaysLB(i, mmy2, k, iv_nup) &
+ + 3 * ryLB(mmy1) * vaysLB(i, mmy1, k, iv_nup)
+ else
+#endif
+ tiysLB(i, my1, k) = tiysLB(i, my1, k) &
+ + (ryLB(mmy1) - ryLB(mmy3)) * vaysLB(i, mmy2, k, iv_nup) &
+ + 2 * ryLB(mmy1) * vaysLB(i, mmy1, k, iv_nup)
+#if(OB)
+ endif
+#endif
+ ! +
+ ! +--y small
+ ! + ~~~~~~~
+ do j = n7, 2, -1
+ tiyiLB(i, j, k) = ryLB(n6myLB) * vayiLB(i, n7myLB, k, iv_nup)
+ enddo
+ do j = n7, 3, -1
+ tiyiLB(i, j, k) = tiyiLB(i, j, k) + (ryLB(j - 1) &
+ - ryLB(j)) * vayiLB(i, j - 1, k, iv_nup)
+ enddo
+ do j = n6, 3, -1
+ tiyiLB(i, j, k) = tiyiLB(i, j, k) + (2 * ryLB(j) + ryLB(j - 1) &
+ - ryLB(j + 1)) * vayiLB(i, j, k, iv_nup)
+ enddo
+ do j = n6 - 1, 2, -1
+ tiyiLB(i, j, k) = tiyiLB(i, j, k) &
+ + ryLB(n5myLB) * vayiLB(i, n6myLB, k, iv_nup)
+ enddo
+ ! +
+ do nn = n6 - 3, n6 - 2
+ n1 = nn + 1
+ n2 = nn + 2
+ do j = nn, 2, -1
+ tiyiLB(i, j, k) = tiyiLB(i, j, k) &
+ + (ryLB(nn) - ryLB(n2)) * vayiLB(i, n2, k, iv_nup)
+ enddo
+ enddo
+ ! +
+ j = 2
+#if(OB)
+ if(openLB) then
+ tiyiLB(i, 2, k) = tiyiLB(i, 2, k) &
+ + (ryLB(m0y2) - ryLB(m0y4)) * vayiLB(i, m0y3, k, iv_nup) &
+ + 3 * ryLB(m0y2) * vayiLB(i, m0y2, k, iv_nup)
+ else
+#endif
+ tiyiLB(i, 2, k) = tiyiLB(i, 2, k) &
+ + (ryLB(m0y2) - ryLB(m0y4)) * vayiLB(i, m0y3, k, iv_nup) &
+ + 2 * ryLB(m0y2) * vayiLB(i, m0y2, k, iv_nup)
+#if(OB)
+ endif
+#endif
+ enddo
+ enddo
+ ! +
+ endif
+ ! +
+ return
+endsubroutine lbcnud_par
diff --git a/MAR/code_mar/lbcnud_srf.f90 b/MAR/code_mar/lbcnud_srf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fc3d2411ee48151745f0806851d1c4b9f4599dee
--- /dev/null
+++ b/MAR/code_mar/lbcnud_srf.f90
@@ -0,0 +1,80 @@
+#include "MAR_pp.def"
+subroutine LBCnud_srf
+ ! +------------------------------------------------------------------------+
+ ! | MAR, Routine LBCnud_srf 4-06-2002 MAR |
+ ! | LBCnud_srf includes the Surface Boundary Conditions |
+ ! | corresponding to Surface Variables |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : sst_LB: Surface Temperature LBC |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | OUTPUT: tsrfSL: Surface Temperature |
+ ! | ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_lb
+ use mar_sl
+ ! +
+ implicit none
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer i, j, k, m
+ logical MAR_SI
+ ! +
+ ! +
+ ! +--Initialization
+ ! + ==============
+ ! +
+ MAR_SI = .false.
+ if(VSISVAT) MAR_SI = .true.
+ ! +
+ ! +
+ ! +--LBC: New Surface Temperatures
+ ! + =============================
+ ! +
+ if(.not. polmod .and. .not. MAR_SI) then
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) <= 2) then
+ tsrfSL(i, j, 1) = sst_LB(i, j)
+
+ ! +---1. Open Water
+ ! + ~~~~~~~~~~~~~
+ if(sst_LB(i, j) > Tfr_LB) then
+ isolSL(i, j) = 1
+ d1_SL(i, j) = 2.09d+8
+ albeSL(i, j) = 0.10
+ eps0SL(i, j) = 0.97
+ SL_z0(i, j, 1) = zs_SL
+ SL_r0(i, j, 1) = 0.1 * zs_SL
+ ch0SL(i, j) = 0.00132
+ rsurSL(i, j) = 0.0
+
+ ! +---2. Sea Ice
+ ! + ~~~~~~~~~~
+ else
+ isolSL(i, j) = 2
+ d1_SL(i, j) = 1.05d+5
+ albeSL(i, j) = 0.70d00
+ eps0SL(i, j) = 0.97d00
+ SL_z0(i, j, 1) = zn_SL
+ SL_r0(i, j, 1) = 0.1 * zn_SL
+ ch0SL(i, j) = 0.0021
+ ! +... (Kondo and Yamazaki, 1990, JAM 29, p.376)
+ rsurSL(i, j) = 0.0
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ ! +
+ return
+endsubroutine LBCnud_srf
diff --git a/MAR/code_mar/libUN.f90 b/MAR/code_mar/libUN.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f7d0685492657f89287f874f0bfcdce1640a39af
--- /dev/null
+++ b/MAR/code_mar/libUN.f90
@@ -0,0 +1,2972 @@
+!--VERSION:2005.04.08
+
+! -----------------------------------------------------------------------
+! libUN : User level NetCDF READ / WRITE routines
+!
+! by Philippe Marbaix and Xavier Fettweis
+!
+! Compatible with NetCDF version 3.x (or above).
+! -----------------------------------------------------------------------
+
+! User-frendly interface :
+! ------------------------
+
+! CF_INI_FILE : Initialization of the netcf file
+! CF_CREATE_DIM : Create axis/dimensions
+! CF_CREATE_VAR : Create variables
+! CF_CREATE_FILE: Write the netcdf file
+! CF_WRITE : Write variables
+! CF_READ3D/2D : Read variables
+! CF_OPEN : Open netcdf file
+! CF_CLOSE : Close netcdf file
+
+! Main routines :
+! ---------------
+
+! UNscreate : General file creation routine,
+! defining multiple dimensions + attributes
+
+! UNwrite : General variables writting routine
+! (also updates 'range' attribute and variable if present)
+! Note: Use UNlwrite to write 2D planes in 3D variables
+
+! UN(s)read : Reading routine (grid coordinates + variable)
+
+! Complementary routines :
+! ------------------------
+
+! UNparam : set optional parameters of libUN functions
+! UNwopen : re-open file for writting
+! UNropen : open file for reading
+! UNgtime : Find time index for a given time value
+! UNgindx : Generalization of UNgtime: find value in any 1D data.
+! UNfindx : modified version of UNgindx safe for non-monotonic data
+! UNclose : close the NetCDF file
+! UNwratt : Real attributes writting
+! UNwcatt : Characters attributes creation & writing
+
+! Double Precision :
+! ------------------
+
+! To be in double precision, type this
+! > sed "s/REAL\*4/REAL\*8/g" libUN.f > libUN1.f
+! > sed "s/\_REAL/\_DOUBLE/g" libUN1.f > libUN2.f
+! > sed "s/NF\_FLOAT/NF\_DOUBLE/g" libUN2.f > libUNd.f
+! > rm -f libUN1.f libUN2.f
+
+! -----------------------------------------------------------------------
+
+! +---------------------------+---------------------------------------+
+! + subroutine CD_INI_FILE : + Initialize the netcdf file +
+! +---------------------------+---------------------------------------+
+
+subroutine CF_INI_FILE(filename, filetitle)
+
+ use libUN_mod
+ ! Input :
+ ! =======
+
+ ! filename = name of the netcdf file
+ ! filetitle = title in the netcdf file
+
+ implicit none
+
+ character * (*) filename, filetitle
+
+ CF_attnam(1) = 'actual_range'
+ CF_attnum(1) = 2
+
+ CF_varnbrtot = 0 ! Initialization
+ CF_dimnbrtot = -1 ! Initialization
+
+ CF_filenam = filename
+ CF_filetit = filetitle
+
+ENDsubroutine CF_INI_FILE
+
+! +-----------------------------+-------------------------------------+
+! + subroutine CF_CREATE_DIM : + Create dimensions/axis +
+! +-----------------------------+-------------------------------------+
+
+subroutine CF_CREATE_DIM(dimname, dimunits, dimdim, vallues)
+ use libUN_mod
+ ! Input :
+ ! =======
+
+ ! dimname = name of the axis/dimension
+ ! dimunits = units of the axis/dimension
+ ! dimdim = dimensions of the axis/dimension
+ ! vallues = vallues of the axis/dimension
+
+ implicit none
+
+ character * (*) dimname, dimunits
+
+ integer dimdim, i
+ REAL(kind=4) vallues(dimdim)
+
+ CF_dimnbrtot = CF_dimnbrtot + 1
+
+ CF_dimnbrtot = max(0, CF_dimnbrtot)
+
+ CF_dimnam(CF_dimnbrtot) = dimname
+ CF_dimnamuni(CF_dimnbrtot) = dimunits
+ CF_dim(CF_dimnbrtot) = dimdim
+
+ do i = 1, dimdim
+ CF_dimval(i, CF_dimnbrtot) = vallues(i)
+ enddo
+
+ENDsubroutine CF_CREATE_DIM
+
+! +-----------------------------+-------------------------------------+
+! + subroutine CF_CREATE_VAR : + Create variables +
+! +-----------------------------+-------------------------------------+
+
+subroutine CF_CREATE_VAR(varname, vartitle, varunits, varaxe4, &
+ varaxe1, varaxe2, varaxe3)
+
+ ! Input :
+ ! =======
+
+ ! varname = name of the variable
+ ! vartitle = title of the variable
+ ! varunits = units of the variable
+ ! varaxeX = axes used by the variable (T,X,Y,Z)
+ use libUN_mod
+ implicit none
+
+ character * (*) varname, vartitle, varunits
+ character * (*) varaxe1, varaxe2, varaxe3, varaxe4
+
+ CF_varnbrtot = max(0, CF_varnbrtot + 1)
+
+ CF_varnam(CF_varnbrtot) = varname
+ CF_varnamdim(1, CF_varnbrtot) = varaxe1
+ CF_varnamdim(2, CF_varnbrtot) = varaxe2
+ CF_varnamdim(3, CF_varnbrtot) = varaxe3
+ CF_varnamdim(4, CF_varnbrtot) = varaxe4
+ CF_varnamuni(CF_varnbrtot) = varunits
+ CF_vardes(CF_varnbrtot) = vartitle
+
+ENDsubroutine CF_CREATE_VAR
+
+! +--------------------------------------+----------------------------+
+! + subroutine CF_CREATE_VAR_VIA_FILE : + Create variables +
+! +--------------------------------------+----------------------------+
+
+subroutine CF_CREATE_VAR_VIA_FILE(filename)
+
+ ! Input :
+ ! =======
+
+ ! filename = name of the file containing informations
+ ! about the variables
+ use libUN_mod
+ implicit none
+
+ character * 200 filename
+
+ character * 120 tmpvar
+
+ OPEN(unit=999, status='old', file=filename)
+
+980 continue
+ READ(999, '(A120)', end=990) tmpvar
+
+ if(tmpvar(1:4) == ' ') then
+ CF_varnbrtot = max(0, CF_varnbrtot + 1)
+ READ(tmpvar, '(4x,5A9,A12,A50)') &
+ CF_varnam(CF_varnbrtot), &
+ CF_varnamdim(1, CF_varnbrtot), &
+ CF_varnamdim(2, CF_varnbrtot), &
+ CF_varnamdim(3, CF_varnbrtot), &
+ CF_varnamdim(4, CF_varnbrtot), &
+ CF_varnamuni(CF_varnbrtot), &
+ CF_vardes(CF_varnbrtot)
+ endif
+
+ GOTO 980
+990 continue
+
+ENDsubroutine CF_CREATE_VAR_VIA_FILE
+
+! +------------------------------+------------------------------------+
+! + subroutine CF_CREATE_FILE : + Create the netcdf file +
+! +------------------------------+------------------------------------+
+
+subroutine CF_CREATE_FILE(filename)
+
+ ! Input :
+ ! =======
+
+ ! filename = name of the netcdf file
+ use libUN_mod
+ implicit none
+
+ character * (*) filename
+
+ integer i, j, id
+
+ integer UN1_dim(0:CF_dimnbrtot)
+
+ real UN1_dimval(CF_dimmaxlen, 0:CF_dimnbrtot)
+
+ character * 31 UN1_dimnam(0:CF_dimnbrtot), &
+ UN1_dimnamuni(0:CF_dimnbrtot)
+
+ if(filename /= CF_filenam) then
+ write(6, *) "ERROR: not "//CF_filenam
+ stop
+ endif
+
+ do i = 0, CF_dimnbrtot
+ UN1_dim(i) = CF_dim(i)
+ UN1_dimnam(i) = CF_dimnam(i)
+ UN1_dimnamuni(i) = CF_dimnamuni(i)
+ do j = 1, CF_dim(i)
+ UN1_dimval(j, i) = CF_dimval(j, i)
+ enddo
+ enddo
+
+ call UNscreate(CF_filenam, CF_filetit, CF_dimnbrtot, UN1_dim, &
+ CF_dimmaxlen, UN1_dimnam, UN1_dimnamuni, &
+ UN1_dimval, &
+ CF_varmaxnbr, CF_varnbrtot, CF_varnam, &
+ CF_varnamdim, CF_varnamuni, CF_vardes, &
+ CF_attnbr, CF_attnam, CF_attnum, id)
+
+ call UNclose(id)
+
+ENDsubroutine CF_CREATE_FILE
+
+! +------------------------+------------------------------------------+
+! + subroutine CF_WRITE : + Writes variables +
+! +------------------------+------------------------------------------+
+
+subroutine CF_WRITE(FILEname, VARname, itime, &
+ Ni, Nj, Nlev, var)
+
+ ! Input :
+ ! =======
+
+ ! FILEname = name of the netcdf file
+ ! VARname = name of variables
+ ! itime = index on time axis
+ ! Ni,Nj,Nlev = X,Y,Z dimension
+ ! var = array of vallues of the variable
+ use libUN_mod
+ implicit none
+
+ character * (*) FILEname, VARname
+ integer itime
+ integer Ni, Nj, Nlev, fileid
+ REAL(kind=4) var(Ni, Nj, Nlev)
+
+ if(CF_filenamopened /= FILEname) then
+ call UNwopen(FILEname, fileid)
+ else
+ fileid = CF_fileidopened
+ endif
+
+ call UNwrite(fileid, VARname, itime, Ni, Nj, Nlev, var)
+
+ if(CF_filenamopened /= FILEname) then
+ call UNclose(fileid)
+ endif
+
+ENDsubroutine CF_WRITE
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine CF_READ2D : + Read variables +
+!** +-------------------------+-----------------------------------------+
+
+subroutine CF_READ2D(FILEname, VARname, itime, &
+ Ni, Nj, Nlev, var)
+
+ ! Input :
+ ! =======
+
+ ! FILEname = name of the netcdf file
+ ! VARname = name of variables
+ ! itime = index on time axis
+ ! Ni,Nj,Nlev = X,Y,Z dimension
+
+ ! Output :
+ ! ========
+
+ ! var = array of vallues of the variable
+ use libUN_mod
+ implicit none
+
+ character * (*) FILEname, VARname
+ character * 31 var_units, filetitle
+ integer Ni, Nj, Nlev, itime, level
+ REAL(kind=4) var(Ni, Nj)
+
+ integer i, j, fileid
+
+ if(CF_filenamopened /= FILEname) then
+ call UNropen(FILEname, fileid, filetitle)
+ else
+ fileid = CF_fileidopened
+ endif
+
+ call UNsread(fileid, VARname, itime, Nlev, 1, 1, &
+ Ni, Nj, 1, var_units, var)
+
+ if(CF_filenamopened /= FILEname) then
+ call UNclose(fileid)
+ endif
+
+ENDsubroutine CF_READ2D
+
+! +-------------------------+-----------------------------------------+
+! + subroutine CF_READ3D : + Read variables +
+! +-------------------------+-----------------------------------------+
+
+subroutine CF_READ3D(FILEname, VARname, itime, &
+ Ni, Nj, Nlev, var)
+
+ ! Input :
+ ! =======
+
+ ! FILEname = name of the netcdf file
+ ! VARname = name of variables
+ ! itime = index on time axis
+ ! Ni,Nj,Nlev = X,Y,Z dimension
+
+ ! Output :
+ ! ========
+
+ ! var = array of vallues of the variable
+ use libUN_mod
+ implicit none
+
+ character * (*) FILEname, VARname
+ character * 32 var_units, filetitle
+ integer Ni, Nj, Nlev, itime, level
+ REAL(kind=4) var(Ni, Nj, Nlev)
+
+ integer i, j, fileid
+
+ if(CF_filenamopened /= FILEname) then
+ call UNropen(FILEname, fileid, filetitle)
+ else
+ fileid = CF_fileidopened
+ endif
+
+ call UNsread(fileid, VARname, itime, 0, 1, 1, &
+ Ni, Nj, Nlev, var_units, var)
+
+ if(CF_filenamopened /= FILEname) then
+ call UNclose(fileid)
+ endif
+
+ENDsubroutine CF_READ3D
+
+!** +------------------------+------------------------------------------+
+!** + subroutine CF_CLOSE : + Close the file +
+!** +------------------------+------------------------------------------+
+
+subroutine CF_CLOSE(FILEname)
+ use libUN_mod
+ implicit none
+
+ character * (*) FILEname
+
+ if(FILEname == CF_filenamopened) then
+ call UNclose(CF_fileidopened)
+ else
+ print *, FILEname//" not opened"
+ endif
+
+ CF_filenamopened = ""
+ CF_fileidopened = 0
+
+ENDsubroutine CF_CLOSE
+
+!** +-----------------------+-------------------------------------------+
+!** + subroutine CF_OPEN : + open the file +
+!** +-----------------------+-------------------------------------------+
+
+subroutine CF_OPEN(FILEname, FILEid)
+ use libUN_mod
+ implicit none
+
+ integer FILEid
+
+ character * (*) FILEname
+
+ call UNwopen(FILEname, FILEid)
+
+ CF_filenamopened = FILEname
+
+ CF_fileidopened = FILEid
+
+ENDsubroutine CF_OPEN
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNscreate : + +
+!** +-------------------------+ +
+!** + * Purpose : +
+!** + Create a NetCDF file, general version. +
+!** + (Staggered grids + other extensions to UNcreate) +
+!** + +
+!** + * How it works : calling routine must provide +
+!** + -a list of dimensions +
+!** + (size of each dimens., names, units and values of coordinates)+
+!** + -a list of variables +
+!** + (units, number of dimensions, names of selected dimensions) +
+!** + +
+!** + INPUT : +
+!** + ------- +
+!** + +
+!** + General : +
+!** + FILEnam [char]: Name of the file to be created. +
+!** + title [char]: Title attribute +
+!** + +
+!** + Dimensions: +
+!** + TND : Total Number of SPATIAL dimensions +
+!** + Notice : Set "time" to dimension No 0 +
+!** + DFdim(0:TND) : # discrete values for each dimension +
+!** + Notice : DFdim(0).eq.0 +
+!** + -> UNLIMITED TIME (coord. not defined) +
+!** + WARNING: In this case, the NetCDF +
+!** + use a temporary space to duplicate +
+!** + the file -> NOT RECOMMENDED +
+!** + MXdim : Maximum value of DFdim, = arrays size +
+!** + NAMdim(0:TND) [char]: Name of dimensions, except time +
+!** + UNIdim(0:TND) [char]: Units of dimensions (attribute) +
+!** + VALdim(MXdim,0:TND)[R4]: Values of coordinate for each dimension+
+!** + +
+!** + Variables: +
+!** + Dvs : Variable's definitions array sizes, +
+!** + Nvs : Number of defined variables(Nvs.le.Dvs)+
+!** + name_vs (Dvs) [char]: name of variable. +
+!** + unit_vs (Dvs) [char]: physical units of variable (attribute) +
+!** + Sdim_vs (4,Dvs) [char]: name of Selected dims (in above list) +
+!** + Blanked or '-' elements = not used +
+!** + lnam_vs (Dvs) [char]: Long_name attribute (descript. of var.)+
+!** + +
+!** + List of real attributes to all variables: +
+!** + Nra : Number of Real Attributes (.ge.1 !) +
+!** + NAMrat(Nra) [char]: NAMes of Real ATtributes (''=none) +
+!** + (initial value= 0; set it with UNwratt)+
+!** + Nvals(Nra) : Number of values of these attributes. +
+!** + ! Currently limited to 1 value (scalar) or 2 (2 elements vector)+
+!** + ! EXCEPTION: Setting the last attribute name to '[var]_range' +
+!** + does create a variable (!) for level-by-level range+
+!** + (very usefull for 3D + time fields) +
+!** + +
+!** + NB : [char] variables may have any length. +
+!** + blanks characters are NOT ALLOWED in any variable, +
+!** + except the "title". +
+!** + and the NetCDF variables defined here are always REAL(kind=4) +
+!** + +
+!** + OUTPUT : +
+!** + -------- +
+!** + FILEid : Index of the NetCDF file (remains open)+
+!** +-------------------------------------------------------------------+
+
+subroutine UNscreate(FILEnam, title, &
+ TND, DFdim, MXdim, NAMdim, UNIdim, VALdim, &
+ Dvs, Nvs, name_vs, Sdim_vs, unit_vs, lnam_vs, &
+ Nra, NAMrat, Nvals, &
+ FILEid)
+ use libUN_mod
+ ! +
+ implicit none
+
+ ! +
+ INTEGER icheck, MXND
+ ! ** Maximum number of dimensions
+ parameter(MXND=100)
+
+ ! + INPUT:
+ ! + - - -
+ character * (*) FILEnam
+ character * (*) title
+
+ integer TND, DFdim(0:TND), MXdim
+ character * (*) NAMdim(0:TND)
+ character * (*) UNIdim(0:TND)
+ REAL(kind=4) VALdim(MXdim, 0:TND)
+
+ integer Nvs, Dvs
+ character * (*) name_vs(Dvs)
+ character * (*) Sdim_vs(4, Dvs)
+ character * (*) unit_vs(Dvs)
+ character * (*) lnam_vs(Dvs)
+
+ integer Nra
+ character * (*) NAMrat(Nra)
+ character * 24 Host, Fdate
+ character * 200 tmpchar
+ integer Nvals(Nra)
+
+ ! + OUTPUT:
+ ! + - - - -
+ INTEGER FILEid
+
+ ! + LOCAL:
+ ! + - - -
+ integer VARSIZE
+ EXTERNAL VARSIZE
+ character * (30) tmpchr
+ integer dimDID(0:MXND)
+ integer dimVID(0:MXND), vsVID, vrVID
+ integer dID(4), start(4), count(4), rdID(2)
+ integer mimaID
+ integer stride(4), imap(4)
+ integer Ndim_vs
+ integer ivs, igd, idi, ira, itmp
+ integer Nlen
+ integer dNlen(0:MXND)
+ integer Ierro, TTerr, ii, jj
+ REAL(kind=4) zero1(1), zero2(2)
+
+ icheck = 0 !Debugging level
+
+ !* 0. Initialisations
+ ! ------------------
+ if(icheck >= 1) write(*, *) 'UNscreate : Begin'
+
+ ! + Routines which opens a file must reset libUN internals:
+ call UNparam('RESET_PARAMS_', 0.0)
+
+ do ii = 1, 4
+ stride(ii) = 1
+ enddo
+ zero1(1) = 0.
+ zero2(1) = 0.
+ zero2(2) = 0.
+ TTerr = 0 !Total of error flags
+
+ if(TND > MXND) then
+ write(*, *) 'UNscreate - Error: so much dimensions ?', TND
+ endif
+
+ ! Create a NetCDF file and enter define mode :
+ ! --------------------------------------------
+ if(icheck >= 2) write(*, *) 'FILEnam :', FILEnam
+
+ ! ** getting FILEnam [char] size :
+ Nlen = VARSIZE(FILEnam)
+
+ Ierro = NF_CREATE(FILEnam(1:Nlen), NF_CLOBBER, FILEid)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ ! ** identif. =>overwrite =error
+
+ !* Time coordinate definition.
+ ! ---------------------------
+
+ ! ** Define dimension :
+ if(icheck >= 3) write(*, *) '# time iters.:', DFdim(0)
+ if(DFdim(0) == 0.) then
+ Ierro = NF_DEF_DIM(FILEid, 'time', NF_UNLIMITED, dimDID(0))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+ else
+ Ierro = NF_DEF_DIM(FILEid, 'time', DFdim(0), dimDID(0))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+ endif
+ dNlen(0) = 4 ! 4 characters in the name 'time'...
+ if(NAMdim(0)(1:4) /= 'time') then
+ write(*, *) 'Sorry, NAMdim(0) must be ''time'' .'
+ STOP
+ endif
+
+ ! ** Define variable for the time coordinate values :
+ dID(1) = dimDID(0)
+ Ierro = NF_DEF_VAR(FILEid, 'time', NF_FLOAT, 1, dID, dimVID(0))
+ ! ** ^^^^^^^^^^ FILEid var name type dims DIMid VARid
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! Spatial coordinates definitions : DIMS and VARs (locations).
+ ! ------------------------------------------------------------
+ !
+ do igd = 1, TND !** BEGIN LOOP over all spatial dims
+ if(icheck >= 3) write(*, *) ' spatial dim:', NAMdim(igd)
+
+ ! ** getting NAMdim [char] size :
+ Nlen = VARSIZE(NAMdim(igd))
+ dNlen(igd) = Nlen !For further use of NAMdim
+
+ Ierro = NF_DEF_DIM(FILEid, NAMdim(igd)(1:Nlen), &
+ DFdim(igd), dimDID(igd))
+ ! **line1 ^^^^^^^^^^ FILEid | dim name
+ ! **line2 # values | VARid
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ dID(1) = dimDID(igd)
+ Ierro = NF_DEF_VAR(FILEid, NAMdim(igd)(1:Nlen), &
+ NF_FLOAT, 1, dID, dimVID(igd))
+ ! **line1 ^^^^^^^^^^ FILEid | dim name
+ ! **line2 type | #dims | dimsIDs | VARid
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ enddo !** END LOOP over all spatial dims
+
+ ! Special coordinate definition: MinMax (for [var]_range)
+ ! -------------------------------------------------------
+ if(NAMrat(Nra)(1:11) == '[var]_range') then
+
+ Ierro = NF_DEF_DIM(FILEid, 'MinMax', 2, mimaID)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ endif
+
+ ! Define the fields.
+ ! ------------------
+
+ do ivs = 1, Nvs !**BEGIN LOOP on var. num.
+ if(icheck >= 3) &
+ WRITE(*, *) 'Defining variable ', name_vs(ivs)
+
+ ! Set space and time dimensions
+ ! - - - - - - - - - - - - - - -
+ ! ** Initialise number of dimensions :
+ Ndim_vs = 0
+
+ do idi = 1, 4 !** BEGIN LOOP on var dims.
+ if(Sdim_vs(idi, ivs)(1:1) /= ' ' &
+ .and. Sdim_vs(idi, ivs)(1:1) /= '-') then !**skip undefined.
+
+ ! ** getting Sdim_vs [char] size :
+ Nlen = VARSIZE(Sdim_vs(idi, ivs))
+
+ ! ** Searching for the dimension index from its name (Sdim_vs)
+ igd = 0
+ do WHILE(Sdim_vs(idi, ivs)(1:Nlen) &
+ /= NAMdim(igd)(1:dNlen(igd)))
+ if(igd == TND) then
+ write(*, *) 'UNscreate-ERROR: Dimension not found:', &
+ Sdim_vs(idi, ivs)(1:Nlen)
+ STOP
+ endif
+ igd = igd + 1
+ enddo
+ ! ** Construct the dimensions id's for that variable (ivs):
+ if(icheck >= 3) &
+ WRITE(*, *) 'using dimension ', NAMdim(igd), dimDID(igd)
+ Ndim_vs = Ndim_vs + 1
+ dID(Ndim_vs) = dimDID(igd)
+
+ endif
+ enddo !** END LOOP on var dims.
+
+ ! Define our special [var]_range field for 4D variables
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if(Ndim_vs == 4 &
+ .and. NAMrat(Nra)(1:11) == '[var]_range') then
+
+ Nlen = VARSIZE(name_vs(ivs))
+ rdID(1) = dID(3) !(4D variable, 3th dim = level)
+ rdID(2) = mimaID !(for min, max)
+ tmpchr = name_vs(ivs)(1:Nlen)//'_range'
+ itmp = Nlen + 6
+ Ierro = NF_DEF_VAR(FILEid, tmpchr(1:itmp), &
+ NF_FLOAT, 2, rdID, vrVID)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ endif
+
+ ! Define fields :
+ ! - - - - - - - -
+ Nlen = VARSIZE(name_vs(ivs))
+ Ierro = NF_DEF_VAR(FILEid, name_vs(ivs)(1:Nlen), &
+ NF_FLOAT, Ndim_vs, dID, vsVID)
+ ! **line1 ^^^^^^^^^^ FILEid | variable name
+ ! **line2 type | #dims | dimsIDs | VARid
+ if(Ierro /= NF_NOERR) &
+ call HANDLE_ERR('UNscreate (field)', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! Set the variable's attributes :
+ ! -------------------------------
+
+ ! ** Units:
+ ! - - - - -
+ ! ** getting unit_vs [char] size :
+ Nlen = VARSIZE(unit_vs(ivs))
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, vsVID, 'units', &
+ Nlen, unit_vs(ivs)(1:Nlen))
+ ! **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+ ! **line2 length | attr.value
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! ** Special case : units = sigma
+ ! - - - - - - - - - - - - - - - -
+ ! In this case, CV convention advises to write the following
+ ! attribute : positive = down
+ !
+ !BUG Nlen = VARSIZE(lnam_vs(ivs))
+
+ if(unit_vs(ivs)(1:Nlen) == '[sigma]' &
+ .OR. unit_vs(ivs)(1:Nlen) == 'sigma_level') then
+ if(icheck >= 3) then
+ write(*, *) 'Unit = sigma -> setting positive attr'
+ endif
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, vsVID, 'positive', &
+ 4, 'down')
+ ! **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+ ! **line2 length | attr.value
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ endif
+
+ ! ** "long_name":
+ ! - - - - - - - -
+ Nlen = VARSIZE(lnam_vs(ivs))
+
+ if(icheck >= 3) &
+ WRITE(*, *) 'Write long_name ', lnam_vs(ivs)(1:Nlen)
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, vsVID, 'long_name', &
+ Nlen, lnam_vs(ivs)(1:Nlen))
+
+ do jj = 1, Nlen
+ if(lnam_vs(ivs)(jj:jj) == " ") lnam_vs(ivs)(jj:jj) = "_"
+ if(lnam_vs(ivs)(jj:jj) == ".") lnam_vs(ivs)(jj:jj) = "_"
+ if(lnam_vs(ivs)(jj:jj) == "(") lnam_vs(ivs)(jj:jj) = "_"
+ if(lnam_vs(ivs)(jj:jj) == ")") lnam_vs(ivs)(jj:jj) = "_"
+ if(lnam_vs(ivs)(jj:jj) == "/") lnam_vs(ivs)(jj:jj) = "_"
+ enddo
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, vsVID, 'standard_name', &
+ Nlen, lnam_vs(ivs)(1:Nlen))
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! ** From the list of real attributes (input argument) :
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ !
+ do ira = 1, Nra
+ if(NAMrat(ira)(1:1) /= ' ') then
+ if(NAMrat(ira)(1:11) == 'valid_range') then
+
+ ! ** The "valid_range" special attribute :
+ Ierro = NF_PUT_ATT_REAL(FILEid, vsVID, 'valid_range', &
+ NF_FLOAT, 2, ValRange)
+ TTerr = TTerr + ABS(Ierro)
+
+ else if(NAMrat(ira)(1:11) /= '[var]_range') then
+
+ ! ** All "regular" attributes :
+ Nlen = VARSIZE(NAMrat(ira))
+ if(Nvals(ira) == 1) then
+ Ierro = NF_PUT_ATT_REAL(FILEid, vsVID, NAMrat(ira)(1:Nlen), &
+ NF_FLOAT, Nvals, zero1)
+ TTerr = TTerr + ABS(Ierro)
+ else if(Nvals(ira) == 2) then
+ Ierro = NF_PUT_ATT_REAL(FILEid, vsVID, NAMrat(ira)(1:Nlen), &
+ NF_FLOAT, Nvals, zero2)
+ TTerr = TTerr + ABS(Ierro)
+ !
+ endif
+ endif
+ endif
+ enddo
+
+ enddo ! **END LOOP on var. num.
+
+ ! Set 'unit' attribute for the dimensions:
+ ! ----------------------------------------
+
+ do igd = 0, TND !** BEGIN LOOP over all spatial dims
+
+ ! ** getting NAMdim [char] size :
+ Nlen = VARSIZE(UNIdim(igd))
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, dimVID(igd), 'units', &
+ Nlen, UNIdim(igd))
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ Nlen = VARSIZE(NAMdim(igd))
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, dimVID(igd), 'long_name', &
+ Nlen, NAMdim(igd))
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, dimVID(igd), 'standard_name', &
+ Nlen, NAMdim(igd))
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ enddo
+
+ ! Global attribute(s).
+ ! --------------------
+
+ ! ** Title (some general file descriptor) :
+ ! ** getting unit_vs [char] size :
+
+ Nlen = VARSIZE(title)
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, NF_GLOBAL, 'title', &
+ Nlen, title(1:Nlen))
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ Nlen = VARSIZE(CF_institution)
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, NF_GLOBAL, 'institution', &
+ Nlen, CF_institution)
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ ! call HostNm(Host, Ierro)
+
+ tmpchar = "libUN ("//CF_libUN_version//") - "//FDate()
+ ! & " - "//Host
+
+ Nlen = VARSIZE(tmpchar)
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, NF_GLOBAL, 'history', &
+ Nlen, tmpchar)
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ Nlen = VARSIZE(NF_INQ_LIBVERS())
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, NF_GLOBAL, 'netcdf', &
+ Nlen, NF_INQ_LIBVERS())
+
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! Leave define mode (!file remains open )
+ ! ---------------------------------------
+ Ierro = NF_ENDDEF(FILEid)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! Writing of dimensions coordinates.
+ ! ----------------------------------
+
+ ! ** Time :
+ ! - - - - -
+
+ start(1) = 1 !Vector of starting indexes values
+ count(1) = DFdim(0) !Vector of total # indexes values
+ if(icheck >= 3) &
+ WRITE(*, *) 'Write coords for ', NAMdim(0), count(1)
+
+ ! ** Set 'imap' to write with NCVPTG; NCVPT could be enough ?
+ ! ** (imap tells NetCDF about the memory locations of var,
+ ! ** we choose NCVPTG because
+ ! ** only a portion of VALdim is written.)
+ imap(1) = 1
+ imap(2) = 0 ! Not used : write only 1 coord.
+
+ Ierro = NF_PUT_VARM_REAL(FILEid, dimVID(0), start, count, &
+ stride, imap, VALdim(1, 0))
+ ! **line 1 ^^^^^^^^^^^^^^^ ID file| id var. |read from... |#data
+ ! **line 2 step |re-arrang|variable(beg.)
+ ! ** (^^^^stride is not used)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ ! ** Space coordinates :
+ ! - - - - - - - - - - - -
+
+ do igd = 1, TND !** BEGIN LOOP over all spatial dims
+
+ start(1) = 1
+ count(1) = DFdim(igd)
+ if(icheck >= 3) &
+ WRITE(*, *) 'Write coords for ', NAMdim(igd), count(1)
+
+ Ierro = NF_PUT_VARM_REAL(FILEid, dimVID(igd), start, count, &
+ stride, imap, VALdim(1, igd))
+ ! ** ^^^^^^^^^^^^^^^^ see above
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNscreate', Ierro)
+
+ TTerr = TTerr + ABS(Ierro)
+
+ enddo !** END LOOP over all spatial dims
+
+ ! Stop if an error occured.
+ ! -------------------------
+
+ if(TTerr /= 0) then
+ STOP 'UNscreate : Sorry, an error occured.'
+ endif
+
+ ! +
+ RETURN
+ENDsubroutine UNscreate
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNwrite : + +
+!** +-------------------------+ +
+!** + * Writes a variable into a NetCDF file, +
+!** + (the NetCDF file must have been created (or re-opened) and +
+!** + closed after all writing operations). +
+!** + * Automatically updates attribute 'actual_range' if available +
+!** + " " special var. '[var]_range' " +
+!** + +
+!** + INPUT : +
+!** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+!** + VARname : name given to the variable to write (must be in file)+
+!** + itime : No of time step to write to +
+!** + Ni,Nj,Nlev: dimensions of 'var' +
+!** + ! Nlev= 1 for 2D and 1D input variables. +
+!** + Nj = 1 for 1D input variables. +
+!** + NB: can not write 1 level of 3D var only (->UNlwrite)+
+!** + +
+!** + var : The variable to be writen +
+!** + +
+!** + REMARK : +
+!** + Truncation of input data is permited: +
+!** + If the dim of "var" > dim in the NetCDF file, +
+!** + "var" is automatically truncted. However, this => WARNING +
+!** + message, UNLESS a specific truncation was "announced" +
+!** + in var: +
+!** + To truncate the first dim to Li, let var(Ni,1,1) = Li +
+!** + To truncate the 2nd dim to Lj, let var(1,Nj,1) = Lj +
+!** + ... (this has no effect exept cancel the "WARNING" message) +
+!** +-------------------------------------------------------------------+
+
+subroutine UNwrite(FILEid, VARname, itime, &
+ Ni, Nj, Nlev, var)
+ use libUN_mod
+ implicit none
+
+ INTEGER icheck
+
+ INTEGER Lvnam
+ PARAMETER(Lvnam=20)
+
+ ! ** input
+ integer FILEid
+ integer itime
+ integer Ni, Nj, Nlev
+ character * (*) VARname
+ REAL(kind=4) var(Ni, Nj, Nlev)
+
+ ! ** local :
+ integer MXlv
+ PARAMETER(MXlv=500)
+ ! ^^^^Maximal # levels for a special output
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER NVRi, NVRj, NVRlev
+ INTEGER Ierro, TTerr, Nvatts, vtype
+ INTEGER dimID(4), dimSIZ(4), count(4)
+ INTEGER start(4), stride(4), imap(4)
+ character * (Lvnam) dimNAM(4)
+ character * (Lvnam) recname
+ character * (30) tmpchr
+ INTEGER varVID
+ INTEGER VNlen, NDIMvar, NSDIvar, tiDI, itmp
+ INTEGER iz, ii, jj, ll
+ INTEGER iUNLIMDIM
+ REAL(kind=4) chkdim
+ REAL(kind=4) Arange(2), sValRange(2)
+ REAL(kind=4) Srange(MXlv, 2)
+ LOGICAL OkRange
+
+ icheck = 0 !** 'debugging' level
+ TTerr = 0 !** 'total number of errors
+
+ if(icheck >= 1) write(*, *) 'UNwrite : Begin'
+
+ !* 1. Get the variable field and dims IDs
+ ! ----------------------------------------
+
+ if(icheck >= 2) write(*, *) 'FILEid :', FILEid
+
+ ! ** getting VARname size :
+ VNlen = VARSIZE(VARname)
+ if(icheck >= 3) write(*, *) 'VNlen :', VNlen
+ if(icheck >= 2) write(*, *) 'VARname :', VARname(1:VNlen)
+
+ ! ** variable field ID :
+ Ierro = NF_INQ_VARID(FILEid, VARname(1:VNlen), varVID)
+
+ ! ** Cancel writing if an error occured : variable undefined ?
+ if(Ierro /= 0 .and. icheck >= 1) then
+ write(*, *) 'UNwrite Info : Variable ', VARname(1:VNlen) &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9999 !** UNwrite_end
+
+ ! ** Inquire about the number of dimensions in var :
+ ! **
+ Ierro = NF_INQ_VAR(FILEid, varVID, recname, vtype, &
+ NDIMvar, dimID, Nvatts)
+ ! ** line1 id/file id/var var name var type
+ ! ** line2 # dims id/dims #attributes
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwrite', Ierro)
+
+ if(icheck >= 2) write(*, *) 'Ierro1. ', Ierro
+
+ !* 2. Dimensions : inquire about file + compare with input data.
+ ! -------------------------------------------------------------
+
+ ! 2.1 Inquire dimensions names and sizes :
+ ! + - - - - - - - - - - - - - - - - - - - - -
+ do iz = 1, 4
+ dimSIZ(iz) = 0
+ dimNAM(iz) = ' '
+ ! ** Set any unused dimension to "0" size / no name
+ enddo
+ do iz = 1, NDIMvar
+ Ierro = NF_INQ_DIM(FILEid, dimID(iz), dimNAM(iz), dimSIZ(iz))
+ ! ** id/file id/dim dimname dimsize
+ ! ** !output output
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwrite', Ierro)
+ enddo
+ if(icheck >= 3) write(*, *) 'NDIMvar ', NDIMvar
+ if(icheck >= 3) write(*, *) 'Ierro 2.0', Ierro
+
+ ! 2.2 Set writing region according to field dimension : 2D or 3D
+ ! + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! ** Set horizontal dimensions (default, for most data) :
+ count(1) = Ni
+ count(2) = Nj
+ ! + ** Other default values:
+ count(3) = 0
+ count(4) = 0
+ start(1) = 1
+ start(2) = 1
+ start(3) = 1
+ start(4) = 1
+
+ ! +- ------3D+time variable in file-----------
+ if(NDIMvar == 4) then
+ ! ** 3D space + time:
+ NSDIvar = 3 ! Nb. space dims
+ tiDI = 4 ! No. of the time dim
+ ! ** write 3D space:
+ start(3) = 1 ! Start of index 3 in var (here = vert. levs)
+ count(3) = Nlev ! Nb. values of index 3 in var
+ ! ** write one time step:
+ start(4) = itime
+ count(4) = 1
+ ! +- ------3D *OR* 2D+time var in file--------
+ else if(NDIMvar == 3) then
+ if(Nlev == 1) then
+ ! ** 2D space + time (standard use of UNlib):
+ NSDIvar = 2
+ tiDI = 3
+ ! ** ...write one time step:
+ start(3) = itime
+ count(3) = 1
+ else
+ ! ** 3D (no time slice):
+ NSDIvar = 3
+ tiDI = 0
+ ! ** ...write 3rd dimension:
+ start(3) = 1
+ count(3) = Nlev
+ endif
+ ! +- ------2D *OR* 1D+time var in file--------
+ else if(NDIMvar == 2) then
+ if(Nj == 1 .and. dimNAM(2)(1:4) == 'time') then
+ ! ** Write a 1D vector at time= itime:
+ NSDIvar = 1
+ tiDI = 2
+ start(2) = itime
+ count(2) = 1
+ else
+ ! ** Usual MAR 2D space (no time):
+ NSDIvar = 2
+ tiDI = 0
+ endif
+ ! +- ------1D *OR* 0D+time var in file--------
+ else if(NDIMvar == 1) then
+ ! ** 1D space or time
+ if(Ni == 1) then
+ ! ** Write a single element (at itime)
+ start(1) = itime
+ count(1) = 1
+ count(2) = 0
+ NSDIvar = 0
+ tiDI = 1
+ else
+ ! ** Write a vector (use only "space" dim 1)
+ NSDIvar = 1
+ tiDI = 0
+ count(2) = 0
+ endif
+ else
+ write(*, *) 'UNwrite ERROR : data field dimension ?'
+ STOP
+ endif
+
+ ! 2.3 Compare file dimensions to input data.
+ ! + - - - - - - - - - - - - - - - - - - - - - -
+ ! ** Save variable size for use as "valid" size (-> range):
+ NVRi = Ni
+ NVRj = Nj
+ NVRlev = Nlev
+ ! ** Space dimensions :
+ if(NSDIvar > 0) then
+ do iz = 1, NSDIvar
+ if(dimSIZ(iz) > count(iz)) then
+ write(*, *) 'UNwrite - WARNING: '
+ write(*, *) ' Your field ', VARname, ' has an empty part.'
+ write(*, *) ' (for the dimension:', dimNAM(iz), ')'
+ else if(dimSIZ(iz) < count(iz)) then
+ ! ** Do display "warning" only if truncation
+ ! was not "correctly announced" (see header)
+ ! (NVR... => stop here when updating the range attribute)
+ if(iz == 1) then
+ chkdim = var(Ni, 1, 1)
+ NVRi = dimSIZ(1)
+ else if(iz == 2) then
+ chkdim = var(1, Nj, 1)
+ NVRj = dimSIZ(2)
+ else if(iz == 3) then
+ chkdim = var(1, 1, Nlev)
+ NVRlev = dimSIZ(3)
+ else
+ chkdim = 0.0
+ endif
+ Ierro = NF_INQ_UNLIMDIM(FILEid, iUNLIMDIM)
+ if(dimID(iz) /= iUNLIMDIM) then
+ if(ABS(chkdim - dimSIZ(iz)) > 0.1) then
+ write(*, *) 'UNwrite - WARNING: '
+ write(*, *) ' Your field ', VARname, ' will be truncated.'
+ write(*, *) ' (for the dimension:', dimNAM(iz), ')'
+ endif
+ count(iz) = dimSIZ(iz)
+ endif
+ endif
+ enddo
+ endif
+
+ ! ** Time dimension (when defined):
+ if(tiDI /= 0) then
+ if(itime > dimSIZ(tiDI)) then
+ if(icheck >= 1) write(*, *) 'Time limit, ID', dimID(tiDI)
+ Ierro = NF_INQ_UNLIMDIM(FILEid, iUNLIMDIM)
+ if(dimID(tiDI) /= iUNLIMDIM) then
+ write(*, *) 'UNwrite - ERROR: '
+ write(*, *) ' Time index out of range '
+ STOP
+ endif
+ endif
+ endif
+
+ if(icheck >= 2) write(*, *) 'Ierro2. ', Ierro
+ if(icheck >= 2) write(*, *) 'Dimension names :', dimNAM
+ if(icheck >= 2) write(*, *) 'dimSIZ :', dimSIZ
+ if(icheck >= 2) write(*, *) 'count :', count
+ if(icheck >= 2) write(*, *) 'start :', start
+ if(icheck >= 2) write(*, *) 'dimID :', dimID
+
+ !* 3. Write variable.
+ ! ------------------
+
+ ! ** Set 'imap' and WRITE with NCVPTG:
+ ! ** NOTE : since the arrays (grid_*) may be over-dimensionned,
+ ! ** we use the 'generalised' writing routine NCVPTG
+ ! ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * Ni ! 1st dim of var = Ni
+ imap(3) = imap(2) * Nj ! 2nd dim of var = Nj
+ imap(4) = 0 ! (not used: 0 or 1 time step)
+ do iz = 1, 4
+ stride(iz) = 1
+ enddo
+ ! ** NOTE: stride is not used.
+
+ Ierro = NF_PUT_VARM_REAL(FILEid, varVID, start, count, &
+ stride, imap, var(1, 1, 1))
+ ! ** line1: id/file | id/var |read from...|#data
+ ! ** line2: step |re-arrang|variable(beg.)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwrite', Ierro)
+
+ if(icheck >= 2) write(*, *) 'Ierro3.2', Ierro
+
+ !* 4a. Update 'actual_range' attribute.
+ ! ------------------------------------
+
+ ! If 'actual_range' available, get its current value:
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! ** Get the old min and max values:
+ Ierro = NF_GET_ATT_REAL(FILEid, varVID, 'actual_range', &
+ Arange)
+ ! **line1 ^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+ ! **line2 value
+
+ ! ** Cancel if an error occured : attribute undefined ?
+ if(Ierro /= 0 .and. icheck >= 1) then
+ write(*, *) 'UNwrite Info : attribute actual_range ' &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9990 !** Next section
+
+ ! If 'valid_range' available, get its current value:
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! ** Get the min/max valid range (outside = missing val):
+ Ierro = NF_GET_ATT_REAL(FILEid, varVID, 'valid_range', &
+ sValRange)
+ if(Ierro /= 0) then
+ sValRange(1) = ValRange(1)
+ sValRange(2) = ValRange(2)
+ endif
+
+ ! Update the min an max
+ ! - - - - - - - - - - -
+
+ ! **If this is the first pass, initialise min and max:
+ if(Arange(1) == NF_FILL_REAL &
+ .OR. (Arange(1) == 0.0 .and. Arange(2) == 0.0)) then
+ OkRange = .false.
+ else
+ OkRange = .true.
+ endif
+
+ do ll = 1, NVRlev
+ do jj = 1, NVRj
+ do ii = 1, NVRi
+ if(var(ii, jj, ll) >= sValRange(1) &
+ .and. var(ii, jj, ll) <= sValRange(2)) then
+ if(OkRange) then
+ Arange(1) = MIN(Arange(1), var(ii, jj, ll))
+ Arange(2) = MAX(Arange(2), var(ii, jj, ll))
+ else
+ Arange(1) = var(ii, jj, ll)
+ Arange(2) = var(ii, jj, ll)
+ OkRange = .true.
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ if(icheck >= 2) write(*, *) 'Arange', Arange
+
+ ! Set attribute.
+ ! - - - - - - - -
+
+ Ierro = NF_PUT_ATT_REAL(FILEid, varVID, 'actual_range', &
+ NF_FLOAT, 2, Arange)
+ ! **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+ ! **line2 type |len | attr.value
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwrite', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! ** Next section:
+9990 continue
+
+ !* 5. Update the optional '[var]_range' special variable.
+ ! ------------------------------------------------------
+ if(NDIMvar == 4 .and. Nlev < MXlv) then
+
+ ! If '[var]_range' available, get its current value:
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! ** Get ID of variable [var]_range :
+ tmpchr = VARname(1:VNlen)//'_range'
+ itmp = VNlen + 6
+ Ierro = NF_INQ_VARID(FILEid, tmpchr(1:itmp), varVID)
+
+ ! ** Cancel if an error occured : undefined ?
+ if(Ierro /= 0 .and. icheck >= 1) then
+ write(*, *) 'UNwrite Info : [var]_range ' &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9999 !** UNwrite_end
+
+ ! ** Get the old min and max values:
+ ! ** NOTE :
+ ! ** we use the 'generalised' reading routine NCVGTG
+ ! ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * MXlv
+ start(1) = 1
+ start(2) = 1
+ count(1) = Nlev
+ count(2) = 2
+
+ ! ** (See UNread for explanations about NCVGTG)
+ Ierro = NF_GET_VARM_REAL(FILEid, varVID, start, count, &
+ stride, imap, Srange(1, 1))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwrite', Ierro)
+
+ ! Update the min an max
+ ! - - - - - - - - - - -
+ ! **If this is the first pass, initialise min and max:
+ ! **(Constant fields shall not be accounted for)
+ do ll = 1, Nlev
+ if(Srange(ll, 1) == Srange(ll, 2)) then
+ Srange(ll, 1) = var(1, 1, ll)
+ Srange(ll, 2) = var(1, 1, ll)
+ endif
+ enddo
+
+ do jj = 1, NVRj
+ do ii = 1, NVRi
+ do ll = 1, NVRlev
+ Srange(ll, 1) = MIN(Srange(ll, 1), var(ii, jj, ll))
+ Srange(ll, 2) = MAX(Srange(ll, 2), var(ii, jj, ll))
+ enddo
+ enddo
+ enddo
+ if(icheck >= 4) write(*, *) 'Srange', Srange
+
+ ! Set special variable [var]_range
+ ! - - - - - - - - - - - - - - - - -
+ ! **(See UNread for explanations abtout NCVPTG)
+
+ Ierro = NF_PUT_VARM_REAL(FILEid, varVID, start, count, &
+ stride, imap, Srange(1, 1))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwrite', Ierro)
+
+ endif ! End Section 5.
+
+ ! UNwrite_end
+ ! -----------
+ if(icheck >= 2) write(*, *) 'Errors count:', TTerr
+ if(icheck >= 2) write(*, *) 'UNwrite : End'
+9999 continue
+ RETURN
+END
+!**
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNlwrite : + +
+!** +-------------------------+ +
+!** + * Writes a 2D horizontal LEVEL into a 3D+time NetCDF variable +
+!** + OR a 1D vector into a 2D+time +
+!** + -- ---- -- +
+!** + (SEE ALSO : UNwrite, for all dimensions - this a pecular case +
+!** + Note: 1D vectors are writen in the 1st dim of 2D+time) +
+!** + +
+!** + * Automatically updates attribute 'actual_range' if available +
+!** + " " special var. '[var]_range' " +
+!** + +
+!** + INPUT : +
+!** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+!** + VARname : name given to the variable to write (must be in file)+
+!** + itime : No of time step to write to +
+!** + level : No of level to write to +
+!** + Ni, Nj : dimensions of 'var'... +
+!** + var : A 2D variable to be writen +
+!** +-------------------------------------------------------------------+
+
+subroutine UNlwrite(FILEid, VARname, itime, &
+ ilev, Ni, Nj, var)
+ use libUN_mod
+ implicit none
+
+ INTEGER icheck
+
+ INTEGER Lvnam
+ PARAMETER(Lvnam=20)
+
+ ! ** input
+ INTEGER FILEid
+ INTEGER itime, ilev
+ INTEGER Ni, Nj
+ character * (*) VARname
+ REAL(kind=4) var(Ni, Nj)
+
+ ! ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER Ierro, TTerr, Nvatts, vtype
+ INTEGER dimID(4), dimSIZ(4), count(4)
+ INTEGER start(4), stride(4), imap(4)
+ INTEGER iUNLIMDIM
+ character * (Lvnam) dimNAM(4)
+ character * (Lvnam) recname
+ character * (30) tmpchr
+ INTEGER varVID
+ INTEGER VNlen, NDIMvar, NSDIvar, tiDI, ilDI, itmp
+ INTEGER iz, ii, jj
+ LOGICAL OkRange
+ REAL(kind=4) Arange(2), sValRange(2)
+ REAL(kind=4) Srange(2)
+
+ icheck = 0 !** 'debugging' level
+ TTerr = 0 !** 'total numbe of errors
+
+ if(icheck >= 1) write(*, *) 'UNlwrite : Begin'
+
+ !* 1. Get the variable field and dims IDs
+ ! ----------------------------------------
+
+ if(icheck >= 2) write(*, *) 'FILEid :', FILEid
+
+ ! ** getting VARname size :
+ VNlen = VARSIZE(VARname)
+ if(icheck >= 3) write(*, *) 'VNlen :', VNlen
+ if(icheck >= 2) write(*, *) 'VARname :', VARname(1:VNlen)
+
+ ! ** variable field ID :
+ Ierro = NF_INQ_VARID(FILEid, VARname(1:VNlen), varVID)
+
+ ! ** Cancel writing if an error occured : variable undefined ?
+ if(Ierro /= 0 .and. icheck >= 1) then
+ write(*, *) 'UNlwrite Info : Variable ', VARname(1:VNlen) &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9999 !** UNlwrite_end
+
+ ! ** Inquire about the number of dimensions in var :
+ ! **
+ Ierro = NF_INQ_VAR(FILEid, varVID, recname, vtype, &
+ NDIMvar, dimID, Nvatts)
+ ! ** line1 id/file id/var var name var type
+ ! ** line2 # dims id/dims #attributes
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNlwrite', Ierro)
+
+ if(icheck >= 2) write(*, *) 'Ierro1. ', Ierro
+
+ !* 2. Dimensions : inquire about file + compare with input data.
+ ! -------------------------------------------------------------
+
+ ! 2.1 Inquire dimensions names and sizes :
+ ! + - - - - - - - - - - - - - - - - - - - - -
+ do iz = 1, 4
+ dimSIZ(iz) = 0
+ dimNAM(iz) = ' '
+ ! ** Set any unused dimension to "0" size / no name
+ enddo
+
+ do iz = 1, NDIMvar
+ Ierro = NF_INQ_DIM(FILEid, dimID(iz), dimNAM(iz), dimSIZ(iz))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNlwrite', Ierro)
+ ! ** id/file id/dim dimname dimsize error
+ ! ** !output output
+ enddo
+ if(icheck >= 3) write(*, *) 'NDIMvar ', NDIMvar
+ if(icheck >= 3) write(*, *) 'Ierro 2.0', Ierro
+
+ ! 2.2 Set writing region according to field dimension : 3D
+ ! + - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! ** Set horizontal dimensions (all field dims):
+ count(1) = Ni
+ count(2) = Nj
+ start(1) = 1
+ start(2) = 1
+ ! +- ------ 3D+time var in file--------
+ if(NDIMvar == 4) then
+ NSDIvar = 2 ! Nb. input space dims (for a 2D level)
+ tiDI = 4 ! No. of the time dim
+ ! ** write one level (set the level No) :
+ start(3) = ilev ! Start of index 3 in var
+ count(3) = 1 ! Nb. values of index 3 in var
+ ilDI = 3
+ ! ** write one time step:
+ start(4) = itime
+ count(4) = 1
+ ! +- ------ 2D+time var in file--------
+ else if(NDIMvar == 3) then
+ NSDIvar = 1 ! Nb. input space dims (for a 1D vector)
+ tiDI = 3 ! No. of the time dim
+ ! ** write one "level" - here a 1D vector in the 1st dim.
+ start(2) = ilev ! Start of index 2 in var
+ count(2) = 1 ! Nb. values of index 3 in var
+ ilDI = 2
+ ! ** write one time step:
+ start(3) = itime
+ count(3) = 1
+ else
+ write(*, *) 'UNlwrite ERROR : data field dimension ?'
+ write(*, *) ' NB: UNlwrite = only for (2 or) 3D +time.'
+ STOP
+ endif
+
+ ! 2.3 Compare file dimensions to input data.
+ ! + - - - - - - - - - - - - - - - - - - - - - -
+ ! ** Space dimensions :
+ do iz = 1, NSDIvar
+ if(dimSIZ(iz) > count(iz)) then
+ write(*, *) 'UNlwrite - WARNING: '
+ write(*, *) ' Your field ', VARname, ' has an empty part.'
+ write(*, *) ' (for the dimension:', dimNAM(iz), ')'
+ else if(dimSIZ(iz) < count(iz)) then
+ write(*, *) 'UNlwrite - WARNING: '
+ write(*, *) ' Your field ', VARname, ' will be truncated.'
+ write(*, *) ' (for the dimension:', dimNAM(iz), ')'
+ count(iz) = dimSIZ(iz)
+ endif
+ enddo
+
+ ! ** Space dimensions - check if requested level exists:
+ if(dimSIZ(ilDI) < ilev) then
+ write(*, *) 'UNlwrite - ERROR: '
+ write(*, *) ' The requested level =', ilev
+ write(*, *) ' does not exist in the field ', VARname
+ write(*, *) ' (for the dimension:', dimNAM(ilDI), ')'
+ STOP
+ endif
+
+ ! ** Time dimension (when defined):
+ if(tiDI /= 0) then
+ if(itime > dimSIZ(tiDI)) then
+ if(icheck >= 1) write(*, *) 'Time limit, ID', dimID(tiDI)
+ Ierro = NF_INQ_UNLIMDIM(FILEid, iUNLIMDIM)
+ if(dimID(tiDI) /= iUNLIMDIM) then
+ write(*, *) 'UNlwrite - ERROR: '
+ write(*, *) ' Time index out of range '
+ STOP
+ endif
+ endif
+ endif
+
+ if(icheck >= 2) write(*, *) 'Ierro2. ', Ierro
+ if(icheck >= 2) write(*, *) 'Dimension names :', dimNAM
+ if(icheck >= 3) write(*, *) 'dimSIZ :', dimSIZ
+ if(icheck >= 3) write(*, *) 'count :', count
+ if(icheck >= 3) write(*, *) 'start :', start
+ if(icheck >= 3) write(*, *) 'dimID :', dimID
+
+ !* 3. Write variable.
+ ! ------------------
+
+ ! ** Set 'imap' and WRITE with NCVPTG:
+ ! ** NOTE : since the arrays (grid_*) may be over-dimensionned,
+ ! ** we use the 'generalised' writing routine NCVPTG
+ ! ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * Ni ! 1st dim of var = Ni
+ imap(3) = imap(2) * Nj ! (not used: 1 level...)
+ imap(4) = 0 ! (not used: 0 or 1 time step)
+ do iz = 1, 4
+ stride(iz) = 1
+ enddo
+ ! ** NOTE: stride is not used.
+
+ Ierro = NF_PUT_VARM_REAL(FILEid, varVID, start, count, &
+ stride, imap, var(1, 1))
+ ! ** line1: id/file | id/var |read from...|#data
+ ! ** line2: step |re-arrang|variable(beg.)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNlwrite', Ierro)
+
+ if(icheck >= 2) write(*, *) 'Ierro3.2', Ierro
+
+ !* 4a. Update 'actual_range' attribute.
+ ! ------------------------------------
+
+ ! If 'actual_range' available, get its current value:
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! ** Get the old min and max values:
+ Ierro = NF_GET_ATT_REAL(FILEid, varVID, 'actual_range', &
+ Arange)
+ ! **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+ ! **line2 value
+
+ ! ** Cancel if an error occured : attribute undefined ?
+ if(Ierro /= 0 .and. icheck >= 1) then
+ write(*, *) 'UNlwrite Info : attribute actual_range ' &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9990 !** Next section
+
+ ! If 'valid_range' available, get its current value:
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! ** Get the min/max valid range (outside = missing val):
+ Ierro = NF_GET_ATT_REAL(FILEid, varVID, 'valid_range', &
+ sValRange)
+ if(Ierro /= 0) then
+ sValRange(1) = ValRange(1)
+ sValRange(1) = ValRange(2)
+ endif
+
+ ! Update the min an max
+ ! - - - - - - - - - - -
+
+ ! **If this is the first pass, initialise min and max:
+ if(Arange(1) == NF_FILL_REAL &
+ .OR. (Arange(1) == 0.0 .and. Arange(2) == 0.0)) then
+ OkRange = .false.
+ else
+ OkRange = .true.
+ endif
+
+ do jj = 1, Nj
+ do ii = 1, Ni
+ if(var(ii, jj) >= sValRange(1) &
+ .and. var(ii, jj) <= sValRange(2)) then
+ if(OkRange) then
+ Arange(1) = MIN(Arange(1), var(ii, jj))
+ Arange(2) = MAX(Arange(2), var(ii, jj))
+ else
+ Arange(1) = var(ii, jj)
+ Arange(2) = var(ii, jj)
+ OkRange = .true.
+ endif
+ endif
+ enddo
+ enddo
+ if(icheck >= 2) write(*, *) 'Arange', Arange
+
+ ! Set attribute.
+ ! - - - - - - - -
+
+ Ierro = NF_PUT_ATT_REAL(FILEid, varVID, 'actual_range', &
+ NF_FLOAT, 2, Arange)
+ ! **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+ ! **line2 type |len | attr.value
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNlwrite', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! ** Next section:
+9990 continue
+
+ !* 5. Update the optional '[var]_range' special variable.
+ ! ------------------------------------------------------
+ if(NDIMvar == 4) then
+
+ ! If '[var]_range' available, get its current value:
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! ** Get ID of variable [var]_range :
+ tmpchr = VARname(1:VNlen)//'_range'
+ itmp = VNlen + 6
+ Ierro = NF_INQ_VARID(FILEid, tmpchr(1:itmp), varVID)
+
+ ! ** Cancel if an error occured : undefined ?
+ if(Ierro /= 0 .and. icheck >= 1) then
+ write(*, *) 'UNlwrite Info : [var]_range ' &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9999 !** UNlwrite_end
+
+ ! ** Get the old min and max values:
+ ! ** NOTE :
+ ! ** we use the 'generalised' reading routine NCVGTG
+ ! ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = 0 ! Not used (write only 1 lev)
+ start(1) = ilev
+ count(1) = 1
+ start(2) = 1
+ count(2) = 2
+
+ ! ** (See UNread for explanations abtout NCVGTG)
+ Ierro = NF_GET_VARM_REAL(FILEid, varVID, start, count, &
+ stride, imap, Srange(1))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNlwrite', Ierro)
+
+ ! Update the min an max
+ ! - - - - - - - - - - -
+ ! **If this is the first pass, initialise min and max:
+ ! **(Constant fields shall not be accounted for)
+ if(Srange(1) == Srange(2)) then
+ Srange(1) = var(1, 1)
+ Srange(2) = var(1, 1)
+ endif
+
+ do jj = 1, Nj
+ do ii = 1, Ni
+ Srange(1) = MIN(Srange(1), var(ii, jj))
+ Srange(2) = MAX(Srange(2), var(ii, jj))
+ enddo
+ enddo
+ if(icheck >= 4) write(*, *) 'Srange', Srange
+
+ ! Set special variable [var]_range
+ ! - - - - - - - - - - - - - - - - -
+ ! **(See UNread for explanations abtout NCVPTG)
+
+ Ierro = NF_PUT_VARM_REAL(FILEid, varVID, start, count, &
+ stride, imap, Srange(1))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNlwrite', Ierro)
+
+ endif ! End Section 5.
+
+ ! UNlwrite_end
+ ! -----------
+ if(icheck >= 2) write(*, *) 'Errors count:', TTerr
+ if(icheck >= 2) write(*, *) 'UNlwrite : End'
+9999 continue
+ RETURN
+END
+!**
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNread : + +
+!** +-------------------------+ +
+!** + * Reads a model variable from a NetCDF file, +
+!** + and reads the coordinates of the grid upon wich it is defined. +
+!** + (the NetCDF file must have been opened and must be closed +
+!** + after all reading operations). May read an x-y subregion. +
+!** + +
+!** + INPUT : +
+!** + FILEid : input file identifier (from NetCDF open) +
+!** + VARname : name of the requested variable. +
+!** + time : [integer*4] is the time index of the data field to read +
+!** + level: [integer*4] (usefull for 3D-space fields only) : +
+!** + if not=0 --> = no of the level +
+!** + -> output is 2D (l_dim = 1) +
+!** + if =0 --> read ALL levels +
+!** + -> output is 3D +
+!** + i_dbeg, j_dbeg : horizontal indexes of requested region +
+!** + in input data file +
+!** + i_dim, j_dim, l_dim : ...the dimensions of 'var', +
+!** + = the dimensions of the sub-region to read +
+!** + ! l_dim = 1 if level not=0 +
+!** + ! j_dim = 1 if var is 1D +
+!** + OUTPUT : +
+!** + varax1[i_dim] (real ) +
+!** + varax2[j_dim]: Horizontal coordinates in the file (lat/lon,...)+
+!** + varlev[l_dim]: vertical coordinate of the levels +
+!** + (! when level not=0, only varlev(1) is defined) +
+!** + var_units : physical units of var. +
+!** + var[i_dim,j_dim,l_dim] : +
+!** + data field values +
+!** + (var must be defined, and is REAL ) +
+!** + +
+!** +-------------------------------------------------------------------+
+
+subroutine UNread &
+ (FILEid, VARname, time, level, i_dbeg, j_dbeg, &
+ i_dim, j_dim, l_dim, &
+ varax1, varax2, varlev, &
+ var_units, var)
+ use libUN_mod
+ implicit none
+
+ INTEGER icheck
+
+ INTEGER Lvnam
+ PARAMETER(Lvnam=21)
+
+ ! ** input
+ INTEGER FILEid
+ INTEGER time, level, i_dbeg, j_dbeg
+ INTEGER i_dim, j_dim, l_dim
+ character * (*) VARname
+
+ ! ** output
+ REAL(kind=4) varax1(i_dim), varax2(j_dim), varlev(l_dim)
+ character * (*) var_units
+ REAL(kind=4) var(i_dim, j_dim, l_dim)
+
+ ! ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ REAL(kind=4) varmin, varmax, add_offset, scale_factor
+ INTEGER Ierro, Nvatts, vtype
+ INTEGER dimID(4), dimSIZ(4), dimREG(4)
+ INTEGER start(4), begREG(4), count(4), stride(4), imap(4)
+ character * (Lvnam) dimNAM(4)
+ character * (Lvnam) dNAMver, dNAMtim
+ character * (Lvnam) recname
+ character * (10) Routine
+ INTEGER ax1VID, ax2VID, verVID, timVID, varVID
+ INTEGER VNlen, varNUMDIM
+ INTEGER ii, jj, ll, z
+
+ icheck = 0
+ !* 0. Initialisations
+ ! ------------------
+ Routine = 'UNread'
+ if(icheck >= 1) write(*, *) 'UNread : Begin'
+
+ do ii = 1, 4
+ stride(ii) = 1
+ begREG(ii) = 1
+ start(ii) = 1
+ enddo
+
+ !* 1. Get the variable field and dims IDs
+ ! ----------------------------------------
+
+ if(icheck >= 3) write(*, *) 'FILEid :', FILEid
+
+ ! ** getting VARname size :
+ VNlen = VARSIZE(VARname)
+ if(icheck >= 3) write(*, *) 'VNlen :', VNlen
+ if(icheck >= 2) write(*, *) 'VARname :', VARname(1:VNlen)
+
+ ! ** variable field ID :
+ Ierro = NF_INQ_VARID(FILEid, VARname(1:VNlen), varVID)
+
+ !* 1b. Handle non-existing variables
+ ! ---------------------------------
+ if(Ierro /= NF_NOERR) then
+ if(Ierro == NF_ENOTVAR .and. iVarWarn <= 1) then
+ if(iVarWarn == 1) then
+ write(*, *) 'WARNING (UNsread): variable not found:'
+ write(*, *) ' ', varName
+ endif
+ do ll = 1, l_dim
+ do jj = 1, j_dim
+ do ii = 1, i_dim
+ var(ii, jj, ll) = VarRepl
+ enddo
+ enddo
+ enddo
+ RETURN ! EXIT subroutine, read nothing
+ endif
+ write(*, *) 'Error reading variable: ', VARname(1:VNlen)
+ call HANDLE_ERR('UNsread', Ierro)
+ endif
+
+ ! 1c. Inquire about the number of dimensions in var
+ ! -------------------------------------------------
+
+ Ierro = NF_INQ_VAR(FILEid, varVID, recname, vtype, &
+ varNUMDIM, dimID, Nvatts)
+ ! ** line1 id/file id/var var name var type
+ ! ** line2 # dims id/dims #attributes
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNsread', Ierro)
+
+ if(icheck >= 3) write(*, *) 'Ierro1. ', Ierro
+
+ !* 2. Dimensions : in the reading region and in the file.
+ ! ------------------------------------------------------
+
+ ! ** inquire dimensions names and sizes :
+ do z = 1, varNUMDIM
+ Ierro = NF_INQ_DIM(FILEid, dimID(z), dimNAM(z), dimSIZ(z))
+ ! ** id/file id/dim dimname dimsize
+ ! ** !output output
+ if(Ierro /= NF_NOERR) call HANDLE_ERR(Routine, Ierro)
+ enddo
+
+ ! ** In this version, we read only a xy subregion of the file :
+ dimREG(1) = i_dim
+ dimREG(2) = j_dim
+ begREG(1) = i_dbeg
+ begREG(2) = j_dbeg
+ if(begREG(1) < 1) begREG(1) = 1
+ if(begREG(2) < 1) begREG(2) = 1
+
+ ! ** Set reading region according to field dimension : 2D or 3D
+ if(varNUMDIM == 4) then
+ ! ** for 3D fields :
+ if(level > 0) then
+ ! ** one level is read :
+ dimREG(3) = 1
+ begREG(3) = level
+ dNAMver = dimNAM(3)
+ else
+ ! ** all levels are read :
+ dimREG(3) = l_dim
+ begREG(3) = 1
+ dNAMver = dimNAM(3)
+ endif
+ ! ** one time step is read:
+ dimREG(4) = 1
+ begREG(4) = time
+ dNAMtim = dimNAM(4)
+ else if(varNUMDIM == 3) then
+ ! ** for 2D space fields + time:
+ ! ** one time step is read:
+ dimREG(3) = 1
+ begREG(3) = time
+ dNAMtim = dimNAM(3)
+ dimREG(4) = 0
+ begREG(4) = 0
+ dimNAM(4) = 'none'
+ else if(varNUMDIM == 2) then
+ ! ** for 2D fields :
+ ! ** no time step is read:
+ dimREG(3) = 0
+ begREG(3) = 0
+ dNAMtim = 'none'
+ dimNAM(3) = 'none'
+ dimREG(4) = 0
+ begREG(4) = 0
+ dimNAM(4) = 'none'
+ else if(varNUMDIM == 1) then
+ ! ** for 1D variable :
+ ! ** not assumed to be on a XYZ grid,
+ ! ** just read a vector
+ dimREG(2) = 0
+ begREG(2) = 0
+ dimNAM(2) = 'none'
+ dimREG(3) = 0
+ begREG(3) = 0
+ dimNAM(3) = 'none'
+ dNAMtim = 'none'
+ dimREG(4) = 0
+ begREG(4) = 0
+ dimNAM(4) = 'none'
+ else
+ write(*, *) 'UNread ERROR : data field dimension ?'
+ STOP
+ endif
+
+ do z = 1, varNUMDIM
+ if(begREG(z) > dimSIZ(z)) then
+ write(*, *) 'UNread - ERROR : requested area out '
+ write(*, *) ' of file area. '
+ write(*, *) ' (for the dimension:', dimNAM(z), ')'
+ STOP
+ endif
+ if(dimSIZ(z) < (dimREG(z) + begREG(z) - 1)) then
+ write(*, *) 'UNread - WARNING : empty portion in field, '
+ write(*, *) ' requested region > file contents '
+ write(*, *) ' (for the dimension:', dimNAM(z), ')'
+ dimREG(z) = dimSIZ(z) - begREG(z) + 1
+ endif
+ enddo
+
+ if(icheck >= 3) write(*, *) 'Ierro2. ', Ierro
+ if(icheck >= 2) write(*, *) 'Dimension names :', dimNAM
+ if(icheck >= 2) write(*, *) 'dimSIZ :', dimSIZ
+ if(icheck >= 2) write(*, *) 'dimREG :', dimREG
+ if(icheck >= 2) write(*, *) 'begREG :', begREG
+ if(icheck >= 3) write(*, *) 'dimID :', dimID
+
+ !* 3. Get the variables IDs for the grid points locations.
+ ! -------------------------------------------------------
+
+ if(varNUMDIM >= 2) then
+ Ierro = NF_INQ_VARID(FILEid, dimNAM(1), ax1VID)
+ if(Ierro /= NF_NOERR) then
+ if(Ierro == NF_ENOTVAR) then
+ write(*, *) 'Coordinate values not found:', dimNAM(1)
+ endif
+ call HANDLE_ERR(Routine, Ierro)
+ endif
+ Ierro = NF_INQ_VARID(FILEid, dimNAM(2), ax2VID)
+ if(Ierro /= NF_NOERR) then
+ if(Ierro == NF_ENOTVAR) then
+ write(*, *) 'Coordinate values not found:', dimNAM(2)
+ endif
+ call HANDLE_ERR(Routine, Ierro)
+ endif
+ endif
+ if(varNUMDIM >= 3) then
+ Ierro = NF_INQ_VARID(FILEid, dNAMtim, timVID)
+ if(Ierro /= NF_NOERR) then
+ if(Ierro == NF_ENOTVAR) then
+ write(*, *) 'Coordinate values not found:', dNAMtim
+ endif
+ call HANDLE_ERR(Routine, Ierro)
+ endif
+ endif
+ if(varNUMDIM == 4) then
+ Ierro = NF_INQ_VARID(FILEid, dNAMver, verVID)
+ if(Ierro /= NF_NOERR) then
+ if(Ierro == NF_ENOTVAR) then
+ write(*, *) 'Coordinate values not found:', dNAMver
+ endif
+ call HANDLE_ERR(Routine, Ierro)
+ endif
+ endif
+ ! ** id/file name id/var
+
+ if(icheck >= 3) write(*, *) 'Ierro3. ', Ierro
+
+ !* 4. Get attributes.
+ ! ------------------
+
+ if(varNUMDIM >= 2) then !Not for 1D vectors (special case)
+ ! ** units attribute
+ Ierro = NF_GET_ATT_TEXT(FILEid, varVID, 'units', &
+ var_units)
+ if(Ierro /= NF_NOERR) then
+ if(Ierro == NF_ENOTATT) then
+ write(*, *) 'Note (UNread): units not found for'
+ write(*, *) ' ', varName
+ var_units = ' '
+ else
+ call HANDLE_ERR('UNread', Ierro)
+ endif
+ endif
+
+ if(icheck >= 2) write(*, *) 'var_units :', var_units
+ endif
+
+ Ierro = NF_GET_ATT_REAL(FILEid, varVID, 'scale_factor', &
+ scale_factor)
+
+ Ierro = NF_GET_ATT_REAL(FILEid, varVID, 'add_offset', &
+ add_offset)
+
+ if(Ierro /= NF_NOERR .and. Ierro == NF_ENOTATT) then
+ scale_factor = 1.
+ add_offset = 0.
+ else
+ if(icheck >= 2) &
+ print *, VARname(1:VNlen)//" scale_factor", scale_factor
+ if(icheck >= 2) &
+ print *, VARname(1:VNlen)//" add_offset", add_offset
+ endif
+
+ !* 5. Get values.
+ ! --------------
+ !* 5.1 ...for the grid points locations.
+ ! -------------------------------------
+
+ ! ** Horizontal : always read, except for 1D vectors
+ if(varNUMDIM >= 2) then
+ count(1) = dimREG(1)
+ start(1) = begREG(1)
+ Ierro = NF_GET_VARA_REAL(FILEid, ax1VID, start, count, varax1)
+ ! ** id/file id/var from #data data
+ if(Ierro /= NF_NOERR) call HANDLE_ERR(Routine, Ierro)
+ count(1) = dimREG(2)
+ start(1) = begREG(2)
+ Ierro = NF_GET_VARA_REAL(FILEid, ax2VID, start, count, varax2)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR(Routine, Ierro)
+ endif
+
+ ! ** vertical : only for 3D fields.
+ if(varNUMDIM == 4) then
+ start(1) = begREG(3)
+ count(1) = dimREG(3)
+ Ierro = NF_GET_VARA_REAL(FILEid, verVID, start, count, varlev)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR(Routine, Ierro)
+ endif
+
+ if(icheck >= 3) write(*, *) 'Ierro5.1', Ierro
+
+ !* 5.2 ...for the the variable.
+ ! ----------------------------
+
+ ! ** Set 'imap' and READ with NCVGTG:
+ ! ** NOTE :
+ ! ** we use the 'generalised' reading routine NCVGTG
+ ! ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * i_dim ! 1st dim of var = i_dim
+ imap(3) = imap(2) * j_dim ! 2nd dim of var = j_dim
+ imap(4) = 0 ! Should NEVER be used
+
+ Ierro = NF_GET_VARM_REAL(FILEid, varVID, begREG, dimREG, &
+ stride, imap, var(1, 1, 1))
+ ! ** line1: id/file | id/var |read from...|#data
+ ! ** line2: step |re-arrang|variable(beg.)
+ ! ** NOTE: stride is not used here.
+ if(Ierro /= NF_NOERR) call HANDLE_ERR(Routine, Ierro)
+
+ if(icheck >= 3) write(*, *) 'Ierro5.2', Ierro
+
+ do ll = 1, l_dim
+ do jj = 1, j_dim
+ do ii = 1, i_dim
+ var(ii, jj, ll) = var(ii, jj, ll) * scale_factor &
+ + add_offset
+ enddo
+ enddo
+ enddo
+
+ !* 6. Check data
+ ! -------------
+ if(ireadchk >= 1) then
+ varmax = var(1, 1, 1)
+ varmin = var(1, 1, 1)
+ do ll = 1, l_dim
+ do jj = 1, j_dim
+ do ii = 1, i_dim
+ var(ii, jj, ll) = var(ii, jj, ll) + 0.
+ ! This fixes underflow values but must compile with -fpe1
+ varmax = MAX(var(ii, jj, ll), varmax)
+ varmin = MIN(var(ii, jj, ll), varmin)
+ enddo
+ enddo
+ enddo
+ if(varmin < vReadMin .OR. varmax > vReadMax) then
+ write(*, *) 'WARNING (UNread): variable ', VARname
+ write(*, *) ' is out of specified bounds;'
+ write(*, *) ' min is:', varmin
+ write(*, *) ' max is:', varmax
+ endif
+ endif
+
+ if(icheck >= 2) write(*, *) 'UNread : End'
+
+ENDsubroutine UNread
+
+!**
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNsread : + +
+!** +-------------------------+ +
+!** + * Reads a model variable from a NetCDF file, +
+!** + SIMPLIFIED VERSION of UNread : does NOT read coordinates. +
+!** + +
+!** + +
+!** + INPUT : +
+!** + FILEid : input file identifier (from NetCDF open) +
+!** + VARname : name of the requested variable. +
+!** + time : [integer*4] is the time index of the data field to read +
+!** + level: [integer*4] (usefull for 3D-space fields only) : +
+!** + if not=0 --> = no of the level +
+!** + -> output is 2D (l_dim = 1) +
+!** + if =0 --> read ALL levels +
+!** + -> output is 3D +
+!** + i_dbeg, j_dbeg : horizontal indexes of requested region +
+!** + in input data file +
+!** + i_dim, j_dim, l_dim : ...the dimensions of 'var', +
+!** + = the dimensions of the sub-region to read +
+!** + ! l_dim = 1 if level not=0 +
+!** + ! j_dim = 1 if var is 1D +
+!** + OUTPUT : +
+!** + var_units : physical units of var. +
+!** + var[i_dim,j_dim,l_dim] : +
+!** + data field values +
+!** + (var must be defined, and is REAL ) +
+!** + +
+!** +-------------------------------------------------------------------+
+
+subroutine UNsread &
+ (FILEid, VARname, time, level, i_dbeg, j_dbeg, &
+ i_dim, j_dim, l_dim, &
+ var_units, var)
+
+ implicit none
+
+ ! ** input
+ integer FILEid
+ integer time, level, i_dbeg, j_dbeg
+ integer i_dim, j_dim, l_dim
+ character * (*) VARname
+
+ ! ** output
+ character * (*) var_units
+ REAL(kind=4) var(i_dim, j_dim, l_dim)
+ REAL(kind=4) varax1(i_dim), varax2(j_dim), varlev(l_dim)
+
+ call UNread(FILEid, VARname, time, level, i_dbeg, j_dbeg, &
+ i_dim, j_dim, l_dim, &
+ varax1, varax2, varlev, &
+ var_units, var)
+
+ENDsubroutine UNsread
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNwcatt : + +
+!** +-------------------------+ +
+!** + *Character Attributes creation and (over)writing +
+!** + (the NetCDF file must be open, in data mode) +
+!** + *WARNING: this routine (may?) use a temporary disk space +
+!** + equal to the file length (duplicate the file) +
+!** + +
+!** + INPUT : +
+!** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+!** + varnam : name of variable to which attribute shall be attached+
+!** + or 'GLOBAL_ATT' +
+!** + attnam : name of writen attribute. +
+!** + attval : string to be assigned to attribute. +
+!** + (never inclulde more than 3 consecutive blanks !) +
+!** + +
+!** + Note : all arguments except FILEid are strings of any length +
+!** +-------------------------------------------------------------------+
+
+subroutine UNwcatt(FILEid, varnam, attnam, attval)
+ use libUN_mod
+ implicit none
+ ! **Input:
+
+ INTEGER FILEid
+ character * (*) varnam
+ character * (*) attnam
+ character * (*) attval
+
+ ! **Local:
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER Nlen, Ierro, varVID, Vlen, TTerr
+ INTEGER icheck
+ icheck = 0 !** 'debugging' level
+
+ if(icheck >= 1) write(*, *) 'UNwcatt : Begin'
+
+ !* Get the variable ID
+ ! -------------------
+
+ if(icheck >= 2) write(*, *) 'FILEid :', FILEid
+
+ ! ** getting varnam size :
+ Nlen = VARSIZE(varnam)
+
+ ! ** Case of global attributes:
+ if(varnam(1:Nlen) == 'GLOBAL_ATT') then
+ varVID = NF_GLOBAL
+
+ else
+
+ ! ** Get variable ID to which att is attached to:
+ Ierro = NF_INQ_VARID(FILEid, varnam(1:Nlen), varVID)
+ TTerr = ABS(Ierro)
+
+ ! ** Cancel writing if an error occured : variable undefined ?
+ if(Ierro /= 0) then
+ write(*, *) 'UNwcatt -ERROR : Variable ', varnam(1:Nlen) &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) RETURN !** UNwcatt_end
+
+ endif
+
+ ! Switch to Define Mode,
+ ! because attribute may be created or change size.
+ ! --------------------------------------------------
+ Ierro = NF_REDEF(FILEid)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwcatt', Ierro)
+
+ ! Set attribute.
+ ! --------------
+
+ ! ** getting attnam [char] size :
+ Nlen = VARSIZE(attnam)
+ ! ** getting attval [char] size :
+ Vlen = VARSIZE(attval)
+
+ Ierro = NF_PUT_ATT_TEXT(FILEid, varVID, attnam(1:Nlen), &
+ Vlen, attval(1:Vlen))
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwcatt', Ierro)
+ ! **line1^^^^ FILEid |var.id | attr.name
+ ! **line2 type | len | attr.value | flag
+ TTerr = TTerr + ABS(Ierro)
+
+ ! Leave define mode (!file remains open )
+ ! ---------------------------------------
+ Ierro = NF_ENDDEF(FILEid)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwcatt', Ierro)
+
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNwratt : + +
+!** +-------------------------+ +
+!** + *real attributes writing - ! Can not create new attrib ! +
+!** + (the NetCDF file must be open) +
+!** + +
+!** + INPUT : +
+!** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+!** + varnam : name given to the variable to write (must be in file)+
+!** + attnam : name of treated attribute. +
+!** + Nvals : Number of values of that attribute +
+!** + atvalsi(Nvals) : real vector of values for attribute. +
+!** + +
+!** +-------------------------------------------------------------------+
+
+! WARNING: this routine uses a temporary disk space
+! equal to the file length (duplicate the file)
+! (its use is NOT recommended)
+
+subroutine UNwratt(FILEid, varnam, attnam, Nvals, atvals)
+ use libUN_mod
+ implicit none
+
+ ! **Input:
+
+ INTEGER FILEid, Nvals
+ character * (*) varnam
+ character * (*) attnam
+ REAL(kind=4) atvals(Nvals)
+
+ ! **Local:
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER Nlen, Ierro, varVID
+ INTEGER icheck, TTerr
+ icheck = 0 !** 'debugging' level
+ TTerr = 0
+
+ if(icheck >= 1) write(*, *) 'UNwratt : Begin'
+
+ !* Get the variable ID
+ ! -------------------
+ if(icheck >= 2) write(*, *) 'FILEid :', FILEid
+
+ ! ** getting varnam size :
+ Nlen = VARSIZE(varnam)
+
+ ! ** variable ID :
+ Ierro = NF_INQ_VARID(FILEid, varnam(1:Nlen), varVID)
+ TTerr = TTerr + ABS(Ierro)
+
+ ! ** Cancel writing if an error occured : variable undefined ?
+ if(Ierro /= 0) then
+ write(*, *) 'UNwratt -ERROR : Variable ', varnam(1:Nlen) &
+ , ' not found -> not written.'
+ endif
+ if(Ierro /= 0) GOTO 9999 !** UNwratt_end
+
+ ! Set attribute.
+ ! --------------
+
+ ! ** getting attnam [char] size :
+ Nlen = VARSIZE(attnam)
+
+ Ierro = NF_PUT_ATT_REAL(FILEid, varVID, attnam(1:Nlen), &
+ NF_FLOAT, nvals, atvals)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNwratt', Ierro)
+ ! **line1^^^^FILEid |var.id | attr.name
+ ! **line2 type | attr.value | flag
+ TTerr = TTerr + ABS(Ierro)
+
+9999 continue
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNwopen : + libUN (0896) +
+!** +-------------------------+-----------------------------------------+
+!** + * Open a NetCDF file for writing. +
+!** + +
+!** + INPUT : +
+!** + FILEnam : file name +
+!** + +
+!** + OUTPUT : +
+!** + FILEid : NetCDF file identifier ('logical unit') +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNwopen(FILEnam, FILEid)
+ use libUN_mod
+ implicit none
+
+ ! ** input
+ character * (*) FILEnam
+
+ ! ** output
+ INTEGER FILEid
+
+ ! ** local :
+ INTEGER Ierro
+ INTEGER icheck
+
+ icheck = 0
+
+ ! + Routines which opens a file must reset libUN internals:
+ call UNparam('RESET_PARAMS_', 0.0)
+
+ ! ** Open NetCDF file, for read-only:
+ ! -----------------------------------
+ Ierro = NF_OPEN(FILEnam, NF_WRITE, FILEid)
+ if(Ierro /= NF_NOERR) then
+ write(*, *) 'Error opening file: ', FILEnam
+ call HANDLE_ERR('UNwopen', Ierro)
+ endif
+
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNropen : + libUN (0896) +
+!** +-------------------------+-----------------------------------------+
+!** + * Open a NetCDF file for reading, +
+!** + +
+!** + INPUT : +
+!** + FILEnam : file name +
+!** + +
+!** + OUTPUT : +
+!** + FILEid : NetCDF file identifier ('logical unit') +
+!** + FILEtit : title of the NetCDF file +
+!** + ! [CHAR], must be defined (length > length(title) !) +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNropen(FILEnam, FILEid, FILEtit)
+ use libUN_mod
+ implicit none
+
+ ! ** input
+ character * (*) FILEnam
+
+ ! ** output
+ INTEGER FILEid
+ character * (*) FILEtit
+
+ ! ** local :
+ INTEGER Ierro
+ INTEGER icheck
+
+ icheck = 0
+
+ if(icheck >= 2) write(*, *) 'UNropen: Begin'
+ if(icheck >= 2) write(*, *) 'FILEnam: ', FILEnam
+
+ ! + Routines which opens a file must reset libUN internals:
+ call UNparam('RESET_PARAMS_', 0.0)
+
+ ! ** Open NetCDF file, for read-only:
+ ! -----------------------------------
+ Ierro = NF_OPEN(FILEnam, NF_NOWRITE, FILEid)
+ if(Ierro /= NF_NOERR) then
+ write(*, *) 'Error opening file: ', FILEnam
+ call HANDLE_ERR('UNropen', Ierro)
+ endif
+
+ ! ** Read title attribute,
+ ! ------------------------
+
+ ! ** Read attribute:
+ Ierro = NF_GET_ATT_TEXT(FILEid, NF_GLOBAL, 'title', &
+ FILEtit)
+
+ ! ** Display message if an error occured :
+ ! ** no title or title too long ?
+ ! !if (Ierro.ne.0) then
+ ! ! write(*,*) 'UNropen WARNING: no title or title too long'
+ ! !end if
+ if(icheck >= 2) write(*, *) 'UNropen: End'
+
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNgtime : + libUN (0896) +
+!** +-------------------------+-----------------------------------------+
+!** + * From a given value of desired 'time' coordinate, +
+!** + gets the coordinate index ('iteration no') + found time value +
+!** + +
+!** + INPUT : +
+!** + FILEid : NetCDF file identifier (from UNropen) +
+!** + RQtime : ReQuested time +
+!** + +
+!** + OUTPUT : +
+!** + RDtime : The last time for wich RDtime .le. RQtime +
+!** + Ftime : The next time value Following RDtime +
+!** + (-1 if it would be after end-of-file) +
+!** + it : The time index : RDtime = time(it) +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNgtime(FILEid, RQtime, RDtime, Ftime, it)
+ use libUN_mod
+ implicit none
+
+ INTEGER Lvnam
+ PARAMETER(Lvnam=20)
+
+ ! ** input
+ INTEGER FILEid
+ REAL(kind=4) RQtime
+
+ ! ** output
+ REAL(kind=4) RDtime, Ftime
+ INTEGER it
+
+ ! ** local :
+ INTEGER Ierro, timVID
+ INTEGER timDID
+ REAL(kind=4) gtim
+ INTEGER K, KHI, KLO, Kmax
+ INTEGER Mindex(1)
+ INTEGER icheck
+ character * (Lvnam) dimNAM(1)
+
+ icheck = 0
+
+ ! ** Kmax= nb pas de temps dans le fichier, = dim(time):
+ ! ** - - - - - - - - - - - - - - - - - - - - - - - - - -
+ !
+ Ierro = NF_INQ_DIMID(FILEid, 'time', timDID)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgtime', Ierro)
+ ! **^^ Dimension'time' NetCDF index
+
+ Ierro = NF_INQ_DIM(FILEid, timDID, dimNAM, Kmax)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgtime', Ierro)
+ ! ** id/file id/dim dimname dimsize error
+ ! ** !output output
+
+ ! ** Read/Search the requested time step.
+ ! ** - - - - - - - - - - - - - - - - - - -
+
+ Ierro = NF_INQ_VARID(FILEid, 'time', timVID)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgtime', Ierro)
+ ! **^^ Variable 'time' NetCDF index
+
+ KLO = 1
+ KHI = Kmax
+
+1 if(KHI - KLO > 1) then
+ K = (KHI + KLO) / 2
+
+ ! ** Set the position of the needed time step:
+ Mindex(1) = K
+ ! ** Get 1 time value (gtim = time(K)):
+ Ierro = NF_GET_VAR1_REAL(FILEid, timVID, Mindex, gtim)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgtime', Ierro)
+
+ if(gtim > RQtime) then
+ KHI = K
+ else
+ KLO = K
+ endif
+ GOTO 1
+ endif
+ it = KLO
+ ! ** read RDtime= time(KLO)
+ Mindex(1) = KLO
+ Ierro = NF_GET_VAR1_REAL(FILEid, timVID, Mindex, RDtime)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgtime', Ierro)
+ ! ** read Ftime= time(KHI)
+ Mindex(1) = KHI
+ Ierro = NF_GET_VAR1_REAL(FILEid, timVID, Mindex, Ftime)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgtime', Ierro)
+
+ ! ** if the last available time step is before
+ ! ** the requested time, then KHI and KLO are the
+ ! ** two last available time step. Correct this :
+ if(RQtime >= Ftime) then
+ RDtime = Ftime
+ it = KHI
+ Ftime = -1.0
+ endif
+
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNgindx : + libUN (0199) +
+!** +-------------------------+-----------------------------------------+
+!** + * From a given value of a desired coordinate, +
+!** + gets the coordinate index + found the coresp. coordinate value +
+!** + +
+!** + INPUT : +
+!** + FILEid : NetCDF file identifier (from UNropen) +
+!** + Cname : The name of the coordinate +
+!** + RQval : The requested value for that coordinate +
+!** + +
+!** + OUTPUT : +
+!** + RDval : The last value for wich RDval .le. RQval +
+!** + Fval : The next val value Following RDval +
+!** + (-1 if it would be after end-of-file) +
+!** + indx : The val index : RDval = value_of_Cname(it) +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNgindx(FILEid, Cname, RQval, RDval, Fval, indx)
+ use libUN_mod
+ implicit none
+
+ INTEGER Lvnam
+ PARAMETER(Lvnam=20)
+
+ ! ** input
+ INTEGER FILEid
+ character * (*) Cname
+ REAL(kind=4) RQval
+
+ ! ** output
+ REAL(kind=4) RDval, Fval
+ INTEGER indx
+
+ ! ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ REAL(kind=4) gval
+ INTEGER Ierro
+ INTEGER varDID, VNlen, varVID, varNUMDIM
+ INTEGER Nvatts, vtype
+ INTEGER K, KHI, KLO, Kmax
+ INTEGER Mindex(1), dimID(4)
+ INTEGER icheck
+ character * (Lvnam) dimNAM(4)
+ character * 13 recname
+
+ icheck = 0
+
+ ! ** Kmax= nb pas de temps dans le fichier, = dim(val):
+ ! ** - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! ** get Cname string size :
+ VNlen = VARSIZE(Cname)
+ !
+ ! ** get variable ID :
+ Ierro = NF_INQ_VARID(FILEid, Cname(1:VNlen), varVID)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgindex', Ierro)
+ !
+ ! ** Inquire about the id of the dimension:
+ ! **
+ Ierro = NF_INQ_VAR(FILEid, varVID, recname, vtype, &
+ varNUMDIM, dimID, Nvatts)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgindex', Ierro)
+ ! ** line1 id/file id/var var name var type
+ ! ** line2 # dims id/dims #attributes
+ varDID = dimID(1)
+ ! ^^^At last, the id of the relevant dimension.
+
+ Ierro = NF_INQ_DIM(FILEid, varDID, dimNAM, Kmax)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgindex', Ierro)
+ ! ** id/file id/dim dimname dimsize error
+ ! ** !output output
+ ! ** (Kmax is what we needed: size of the dimension)
+
+ ! ** Read/Search the requested val step.
+ ! ** - - - - - - - - - - - - - - - - - - -
+
+ KLO = 1
+ KHI = Kmax
+
+1 if(KHI - KLO > 1) then
+ K = (KHI + KLO) / 2
+
+ ! ** Set the position of the needed val step:
+ Mindex(1) = K
+ ! ** Get 1 val value (gval = val(K)):
+ Ierro = NF_GET_VAR1_REAL(FILEid, varVID, Mindex, gval)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgindex', Ierro)
+
+ if(gval > RQval) then
+ KHI = K
+ else
+ KLO = K
+ endif
+ GOTO 1
+ endif
+ indx = KLO
+ ! ** read RDval= val(KLO)
+ Mindex(1) = KLO
+ Ierro = NF_GET_VAR1_REAL(FILEid, varVID, Mindex, RDval)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgindex', Ierro)
+ ! ** read Fval= val(KHI)
+ Mindex(1) = KHI
+ Ierro = NF_GET_VAR1_REAL(FILEid, varVID, Mindex, Fval)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNgindex', Ierro)
+
+ ! ** if the last available val step is before
+ ! ** the requested val, then KHI and KLO are the
+ ! ** two last available val step. Correct this :
+ if(RQval >= Fval) then
+ RDval = Fval
+ indx = KHI
+ Fval = -1.0
+ endif
+
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNfindx : + (libUN 2003)+
+!** +-------------------------+-----------------------------------------+
+!** + * Intended to replace UNgindx or UNgtime +
+!** + From a given value of a desired coordinate, +
+!** + gets the coordinate index + the coresp. coordinate value +
+!** + This version solves the issue of Dates at year change +
+!** + occuring because 1 jan is < 31 dec. Not optimised. +
+!** + +
+!** + INPUT : +
+!** + FILEid : NetCDF file identifier (from UNropen) +
+!** + Cname : The name of the coordinate +
+!** + RQval : The requested value for that coordinate +
+!** + +
+!** + OUTPUT : +
+!** + RDval : The file value closest to RQval +
+!** + Fval : The next value in the file +
+!** + (-1 if after file end) +
+!** + (This is mainly for compatibility with older version)+
+!** + indx : The val index : RDval = value_of_Cname(it) +
+!** + (-1 may be returned if the value can't be found) +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNfindx(FILEid, Cname, RQval, RDval, Fval, indx)
+ use libUN_mod
+ implicit none
+
+ INTEGER Lvnam
+ PARAMETER(Lvnam=20)
+
+ ! ** input
+ INTEGER FILEid
+ character * (*) Cname
+ REAL(kind=4) RQval
+
+ ! ** output
+ REAL(kind=4) RDval, Fval
+ INTEGER indx
+
+ ! ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ REAL(kind=4) gval, bmatch, gdist
+ INTEGER Ierro
+ INTEGER varDID, VNlen, varVID, varNUMDIM
+ INTEGER Nvatts, vtype
+ INTEGER K, KHI, KLO, Kmax
+ INTEGER Mindex(1), dimID(4)
+ INTEGER icheck
+ character * (Lvnam) dimNAM(4)
+ character * 13 recname
+
+ icheck = 0
+
+ ! ** Kmax= nb pas de temps dans le fichier, = dim(val):
+ ! ** - - - - - - - - - - - - - - - - - - - - - - - - - -
+ ! ** get Cname string size :
+ VNlen = VARSIZE(Cname)
+ !
+ ! ** get variable ID :
+ Ierro = NF_INQ_VARID(FILEid, Cname(1:VNlen), varVID)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNfindex', Ierro)
+ !
+ ! ** Inquire about the id of the dimension:
+ ! **
+ Ierro = NF_INQ_VAR(FILEid, varVID, recname, vtype, &
+ varNUMDIM, dimID, Nvatts)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNfindex', Ierro)
+ ! ** line1 id/file id/var var name var type
+ ! ** line2 # dims id/dims #attributes
+ varDID = dimID(1)
+ ! ^^^At last, the id of the relevant dimension.
+
+ Ierro = NF_INQ_DIM(FILEid, varDID, dimNAM, Kmax)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNfindex', Ierro)
+ ! ** id/file id/dim dimname dimsize error
+ ! ** !output output
+ ! ** (Kmax is what we needed: size of the dimension)
+
+ ! ** Read/Search the requested val step.
+ ! ** - - - - - - - - - - - - - - - - - - -
+
+ ! This is a workaround, not optimised as stated above.
+ ! We simply look at all values sequencially.
+ !
+ bmatch = 1.E10
+ KLO = -1
+
+ do K = 1, KMAX
+
+ ! ** Get 1 val value (gval = val(K)):
+ Mindex(1) = K
+ Ierro = NF_GET_VAR1_REAL(FILEid, varVID, Mindex, gval)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNfindex', Ierro)
+
+ gdist = ABS(gval - RQval)
+ if(gdist < bmatch) then
+
+ bmatch = gdist
+ KLO = K
+
+ endif
+
+ enddo
+
+ indx = KLO
+
+ KHI = min((KLO + 1), KMAX)
+
+ ! ** read values...
+
+ Mindex(1) = KLO
+ Ierro = NF_GET_VAR1_REAL(FILEid, varVID, Mindex, RDval)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNfindex', Ierro)
+ ! ** read Fval= val(KHI)
+ Mindex(1) = KHI
+ Ierro = NF_GET_VAR1_REAL(FILEid, varVID, Mindex, Fval)
+ if(Ierro /= NF_NOERR) call HANDLE_ERR('UNfindex', Ierro)
+
+ if(KHI == KLO) then
+ Fval = -1.0
+ endif
+
+ if(bmatch > 1.E9) then
+ Fval = -1.0
+ indx = -1
+ endif
+
+ RETURN
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNclose : + libUN (0300) +
+!** +-------------------------+-----------------------------------------+
+!** + * Close the desired file +
+!** + Created to suppress the need the directly call a netcdf +
+!** + routine from a program +
+!** + +
+!** + INPUT : +
+!** + FILEid : NetCDF file identifier (from UNropen) +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNCLOSE(FILEid)
+ use libUN_mod
+ implicit none
+
+ integer Ierro, FILEid
+
+ Ierro = NF_CLOSE(FILEid)
+ if(Ierro /= NF_NOERR) then
+ call HANDLE_ERR('UNclose', Ierro)
+ endif
+
+END
+
+!** +-------------------------+-----------------------------------------+
+!** + subroutine UNparam : + libUN (0202) +
+!** +-------------------------+-----------------------------------------+
+!** + Changes some global libUN parameters +
+!** + NB: default values are set at first libUN call +
+!** + +
+!** + +
+!** + INPUT : pname name of the parameters to set +
+!** + pvalue the requested new value +
+!** + +
+!** +---------------------------------------------------------------7++++
+
+subroutine UNparam(pname, pvalue)
+ use libUN_mod
+ implicit none
+
+ character * (*) pname
+ REAL(kind=4) pvalue
+
+ LOGICAL Lstart
+ SAVE Lstart
+ DATA Lstart/.true./
+
+ if(pname == 'RESET_PARAMS_') then
+ if(Lstart .OR. pvalue > 0.5) then
+ vMissVal = 1.0E21 ! for missing values
+ VarRepl = vMissVal ! for missing VARIABLES
+ ValRange(1) = -vMissVal / 10.
+ ValRange(2) = vMissVal / 10.
+ iVarWarn = 2
+ vReadMin = 0.0
+ vReadMax = 0.0
+ ireadchk = 0
+ Lstart = .false.
+ endif
+
+ else if(pname == 'NOVAR_REPLACE') then
+ VarRepl = pvalue
+
+ else if(pname == 'NOVAR_WARNING') then
+ iVarWarn = NINT(pvalue)
+
+ else if(pname == 'VALID_RANGE_MIN') then
+ ValRange(1) = pvalue
+
+ else if(pname == 'VALID_RANGE_MAX') then
+ ValRange(2) = pvalue
+
+ else if(pname == 'READOVER_WARN') then
+ vReadMin = -pvalue
+ vReadMax = pvalue
+ ireadchk = 1
+
+ else if(pname == 'READ_MIN_WARN') then
+ vReadMin = pvalue
+ ireadchk = 1
+
+ else if(pname == 'READ_MAX_WARN') then
+ vReadMax = pvalue
+ ireadchk = 1
+
+ else
+ write(*, *) 'UNparam (libUN) Error: '
+ write(*, *) ' parameter undefined:', pname
+
+ endif
+
+END
+
+!** +-------------------------+-----------------------------------------+
+subroutine UNversion(UNver, NCDFver)
+ !** +-------------------------+-----------------------------------------+
+ use libUN_mod
+ implicit none
+
+ character * 80 UNver, NCDFver
+
+ UNver = '2005.03.31'
+ NCDFver = NF_INQ_LIBVERS()
+
+END
+
+!** +-------------------------------------------------------------------+
+FUNCTION VARSIZE(CHAvar)
+ !** +-------------------------------------------------------------------+
+ implicit none
+ integer maxcha, iz, VARSIZE
+ parameter(maxcha=512)
+ character * (*) CHAvar
+ character * (maxcha) CHAtmp
+
+ write(CHAtmp, '(A)') CHAvar
+ iz = 0
+ do while((CHAtmp(iz + 1:iz + 3) /= ' ') .and. (iz + 3 <= maxcha))
+ iz = iz + 1
+ enddo
+ VARSIZE = iz
+
+ RETURN
+END
+
+!** +-------------------------------------------------------------------+
+subroutine HANDLE_ERR(LOCATION, STATUS)
+ !** +-------------------------------------------------------------------+
+ use libUN_mod
+ implicit none
+
+ character * (*) LOCATION
+ integer STATUS
+ if(STATUS /= NF_NOERR) then
+ write(*, *) 'IN ROUTINE ', LOCATION
+ write(*, *) NF_STRERROR(STATUS)
+ STOP 'Stopped'
+ endif
+END
+
+! UN library: history of fixed bugs and updates.
+! ----------------------------------------------
+!
+! 961206 - UNgtime, trouble at end-of-file
+! 961218 - - all -, display 'artificial' errors
+! 970318 - again, display 'artificial' errors
+! 971028 - (3 sub),'syntax'error on Cray computer
+! 971105 - Allowed variable "imap(1)", =8 for Cray
+! 980705 - "single element" extension to UNwrite.
+! 980709 - bug fixes (start) in UNwrite & UNlwrite
+! ("DATA" statement incorrectly used).
+! 980825 - Changed default "stride" to 1 for v3.x
+! 981222 - bug fix: allow UNwrite for unlim dims.
+! note that this should be tested.
+! 990110 - Added "UNgindx" = general. of UNgtime
+! - Removed all "DATA" and all "//" in write
+! (the later should improve compatibility)
+! 990128 - UNwrite: added a "no warning" option.
+! 990323 - UNwrite: added 1D+time capability.
+! 990807 - UNwrite: added 3D-notime capability.
+! -----------------------------------------------------------------------
+! 000404 - Major upgrade: compatibility with
+! NetCDF v3.4
+! - NOTE: Types other than REAL may be
+! accepted in UNread, but not tested
+! -----------------------------------------------------------------------
+! 000614 - Bug fixes: uninitialised error count
+! in UNwcatt, bug in UNclose.
+! 000620 - Bug fix: UNropen(args. of get title fn)
+! 000713 - Bug fix: UNgtime (missing arg in a call)
+! (last tree caused by 000404 upgrade)
+! -----------------------------------------------------------------------
+! 000928 - UNlwrite: added 2D+time capability.
+! 001008 - All: character*(*) declaration for units
+! and longer strings for intern. variables
+! 010417 - UNread: added var not found info
+! UNropen: added file not found info
+! 010715 - UNwrite + UNlwrite:
+! fixed bug / unlimited time dim
+! 0107xx - UNwrite:
+! missing values -> not in "range"
+! 020130 - All:
+! .removed obsolete warnings about
+! double precision in files.
+! .added a version (libUN_dbl) with
+! REAL*8 as arguments - but still
+! creates REAL(kind=4) in files.
+! 020526 - Added UNparam function,
+! which provide optional features such
+! as missing variable behavior control
+! 020808 - Very simple fix for underflows while
+! reading some files; must use -fpe1
+! Fixed a bug -> out of range msg
+! 030121 - Enabled some non-standard NetCDF files
+! (missing units...) -> new warnings
+! rather then program stop.
+! 030215 - Added UNfindx for non-monotonic data
+! 030215 - Removed warning related to UNLIM dims
+! 030311 - Added VALID_RANGE attribute (option)
+! (if set, the range is accounted for
+! in the min/max set while writing vars)
+! 040902 - Improvements to "valid_range" attribute
+! - Added attribute "positive=down"
+! if units are sigma or sigma_level
+! 050331 - Added "user friendly" interfaces
diff --git a/MAR/code_mar/libUN_mod.f90 b/MAR/code_mar/libUN_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a5361740d84c00e090b22ba819ee9a9af632225e
--- /dev/null
+++ b/MAR/code_mar/libUN_mod.f90
@@ -0,0 +1,27 @@
+module libUN_mod
+ implicit none
+ INCLUDE 'NetCDF.inc'
+ character(50), PARAMETER :: CF_institution = "ULg (Xavier Fettweis)"
+ character(10), PARAMETER :: CF_libUN_version = "2005.04.08"
+ ! CF_dimmaxlen : Maximum dim/axes length
+ INTEGER, PARAMETER :: CF_dimmaxlen = 99999
+ ! CF_dimmaxnbr : Nbr Maximum of dim/axes
+ INTEGER, PARAMETER :: CF_dimmaxnbr = 20
+ ! CF_varmaxnbr : Nbr maximum of variables
+ INTEGER, PARAMETER :: CF_varmaxnbr = 300
+ ! CF_attnbr : nbr of attibutes
+ INTEGER, PARAMETER :: CF_attnbr = 1
+ INTEGER, SAVE :: CF_dim(0:CF_dimmaxnbr), CF_attnum(CF_attnbr)
+ INTEGER, SAVE :: CF_varnbrtot, CF_dimnbrtot, CF_fileidopened
+ REAL, SAVE :: CF_dimval(CF_dimmaxlen, 0:CF_dimmaxnbr)
+ character(len=13), SAVE :: CF_dimnam(0:CF_dimmaxnbr)
+ character(len=13), SAVE :: CF_varnam(CF_varmaxnbr)
+ character(len=13), SAVE :: CF_varnamdim(4, CF_varmaxnbr)
+ character(len=13), SAVE :: CF_attnam(CF_attnbr)
+ character(len=31), SAVE :: CF_dimnamuni(0:CF_dimmaxnbr)
+ character(len=31), SAVE :: CF_varnamuni(CF_varmaxnbr)
+ character(len=50), SAVE :: CF_vardes(CF_varmaxnbr)
+ character(len=200), SAVE :: CF_filenam, CF_filetit, CF_filenamopened
+ INTEGER, SAVE :: iVarWarn, ireadchk
+ REAL, SAVE :: VarRepl, vReadMin, vReadMax, vMissVal, ValRange(2)
+endmodule libUN_mod
diff --git a/MAR/code_mar/mar.f90 b/MAR/code_mar/mar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e2b89840f20cd0e970130e7ee302f9d647812854
--- /dev/null
+++ b/MAR/code_mar/mar.f90
@@ -0,0 +1,2733 @@
+#include "MAR_pp.def"
+! +************************************************************************+
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | M M AAAAAAA RRRRRRR |
+! | MM MM A A R R |
+! | M M M M A A R R |
+! | M M M M A A R R |
+! | M MM M A AAAAA A R RRRRR R |
+! | M M A A R R |
+! | (MODELE tridimensionnel ATMOSPHERIQUE a l'echelle REGIONALE) |
+! | M M A A R R |
+! | M M A A R R |
+! | M M A A R R |
+! | M M A A R R |
+! | |
+! | \__ _ ____ / |
+! | \_/ @@@@ / \ |
+! | / \ @@@@@@ / / \ |
+! | / \ @@@@@@ | / | |
+! | ... *** \ / / LGGE/IGE/LSCE/CNRS |
+! | .... ** \/___/ |
+! | .... ** / IAG/UCL ULIEGE/FNRS |
+! | |
+! | Laboratoire de Glaciologie et de Geophysique de l'Environnement |
+! | Institut d'Astronomie et de Geophysique Georges Lemaitre |
+! | Laboratoire d'etudes des Transferts en Hydrologie et Environnement |
+! | |
+! | |
+! | |
+! +************************************************************************+
+! | |
+! | Version MARv3.13.0 13 Dec 2022 |
+! | |
+! +************************************************************************+
+! | |
+! | MAR CURRENT CONTRIBUTORS: |
+! | |
+! | H. Gallee, X. Fettweis, C. Agosta, C. Amory, C. Kittel, ... |
+! | |
+! +************************************************************************+
+! | |
+! | SUMMARY : THE MODEL USES THE FULL COMPRESSIBLE PRIMITIVES EQUATIONS |
+! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | Vertical Coordinate : Normalized Pressure Sigma |
+! | Horizontal Grid : Arakawa A-grid |
+! | (Purser and Leslie, MWR 116, 2069--2080, 1988) |
+! | Modes : 1-Dimensional (mx=1,my=1,mz) OR |
+! | ^^^^^^^ 2-Dimensional (mx ,my=1,mz) OR |
+! | 3-Dimensional (mx ,my ,mz) |
+! | Condition mx > my must be fulfilled in this case |
+! | (cfr."MARdim.inc") |
+! | |
+! +************************************************************************+
+! | |
+! | THE FILE MAR___.FOR contains the BASIC SOURCE CODE |
+! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | It may be used as is in 1-D, 2-D or 3-D Mode |
+! | It may be modified in order to allow other possibilities. |
+! | Modifications are performed by replacing labels `c #XY' by blanks. |
+! | (see Preprocessor MAR_pp.for) |
+! | |
+! | # MAIN OPTIONS: |
+! | #^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: Dynamics |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: Sea, Polynya and Snow Models |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: BOUNDARY CONDITIONS |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: CONVECTIVE ADJUSTMENT |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: VERTICAL TURBULENCE |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: SURFACE LAYER |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | |
+! | # ADDITIONAL OPTIONS: HORIZONTAL DifFUSION |
+! | #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+! | !. `Standard' Horizontal Diffusion is performed on Sigma Surfaces |
+! | !. Smagorinski Relation (see Tag et al. 1979, JAM 18, 1429--1441) |
+! | !. CAUTION: Horizontal Diffusion is switched on with turhor = .true. |
+! | 2. _PE, _HH, : Diffus.on Sigma Surfaces (%Grad.) +Vert.Corr. |
+! | 3. _PE, _HH, #CR : Diffus.on Sigma Surfaces (%Grad.) +all Corr. |
+! | 4. #DF, #PE, : Diffus.on Sigma Surfaces (%Strain)+Vert.Corr. |
+! | 5. #DF, #PE, #DC, #CR : Diffus.on Sigma Surfaces (%Strain)+all Corr. |
+! | (#DC -> u,v; #CR -> other Variables) |
+! | CAUTION: if #QE, then #qe MUST BE SWITCHED ON before 2, 3, 4 OR 5 |
+! | ^^^^^^^ if #HY, then #se MUST BE SWITCHED ON before 2, 3, 4 OR 5 |
+! | |
+! +************************************************************************+
+
+program MAR
+ use mardim
+#if(AO)
+ ! Coupling Module / OASIS
+ ! ========================
+ !AO_CK 20/02/2020
+ use mod_OASIS
+ use mar_module
+ ! USE flincom !CK??
+#endif
+ use marctr
+ use marphy
+ use margrd
+ use mar_ge
+ use marsnd
+ use mar_dy
+ use marqqm
+#if(NH)
+ use mar_nh
+#endif
+ use mar_lb
+ use mar_ub
+ use mar_te
+ use mar_tu
+ use mar_ca
+ use mar_fi
+ use mar_hy
+#if(TC)
+ use mar_tc
+#endif
+ use mar_ra
+ use mar_sl
+#if(AO)
+ use mar_ao
+#endif
+ use mar_wk
+ use mar_sv
+ use mardsv
+ use mar_tv
+ use marlsv
+ use marssn
+ use mar_ib
+ use mar_io
+ use marmagic
+ use radcep
+ use marvec
+ use trackwind, only : track_wind, delta_u, delta_v, uairDY_save, vairDY_save, &
+ i_dyndgz, i_dynfil, i_coriol, i_turhor, i_turabl, i_lbcnud, trackwind_init, &
+ track_dgz, delta_u_dgz, delta_v_dgz, trackdgz_init
+ use trackwater, only: track_water, delta_qv, qvDY_save, trackwater_init, &
+ j_dynadv, j_turhor, j_turabl, j_sspray, j_hydgen, j_lbcnud, j_cvagen
+
+#if(iso)
+ use mariso, only : mariso_constants
+#endif
+ implicit none
+
+#if(iso)
+ ! iso_time : number of the output file increment
+ integer :: iso_time
+ ! iso_label : label of output increment
+ character*10 :: iso_label
+#endif
+ ! +--Local Variables
+ ! + ================
+ integer ipr_nc
+ logical qqmass
+ integer norder_0
+ integer newlbc_0
+ real rhcrit_0
+ real tstart_0
+ character * 3 DYNadv
+ real dt_inv, dtLLoc, dtDifH, dt_Out, deltaF, cfladv, csnd
+ real hham, hhac, fham, thac, argham, hhhnnn, tdt, afdt
+ real pav, ppp, wwwabs, wwwmax, ectnew, pente, dthdz, adum, adu
+ real pnhLav, pnh_av, ave_swd
+ integer i, j, k, m
+ integer n, mlg, mlh, mlm, mld, iargum, i__min, i__max
+ integer kk, kdim, ksig, iv, iw
+ integer nt_Loc, jt_Loc, it_Loc, ntLLoc, itLLoc, itPhys
+ integer iham, nham, ihamr, nhamr, jham, ibd
+ integer jmmd, jm10, jh10, jh1, jd10, jd1
+ integer iteChi
+ integer iprint, log_nc
+ integer iout, idum, jdum, id6, i_wmax, j_wmax, k_wmax
+ integer ntracr, lotrac
+ ! Auxil. Variables (variable nt_Mix)
+ logical ntFlog
+ integer nt_BAK, nt_sig, nt_smooth, nt_Mix_min
+ integer nt_Mix_nbr(20), nt_tmp1, nt_tmp2
+ real VLoc, VLocmx, rtFact, CFLinv, TLocmn
+ integer iLocmx, jLocmx, kLocmx
+ ! DistST: Normalized Earth's Sun Distance
+ real DistST
+ character(len = 8) ttime
+ ! +--Check openmp
+ ! + ------------
+ integer number_threads
+ integer omp_get_thread_num, omp_get_max_threads
+ ! +--Vertically Integrated Normalized Mass Flux
+ ! + ------------------------------------------
+ real fu(mx, my), fv(mx, my)
+ ! +--Machine Precision
+ ! + -----------------
+ real reamin, reamax
+ ! +--IO
+ ! + --
+ real zza(5)
+ real tta(5)
+
+ ! MAR allocate
+ call mar_allocate()
+
+ ! +--Flags
+ ! + =====
+ openmp = .false.
+ !$ openmp = .true.
+ ini_KA_TE = .false.
+ VSISVAT = .true.
+ iniIRs = .false.
+ iniOUT = .false.
+ ! +--Blowing Snow
+ ! + ~~~~~~~~~~~~
+ BloMod = .false.
+#if(AE)
+ BloMod = .true.
+#endif
+ ! +--Advection
+ ! + ~~~~~~~~~
+ DYNadv = 'LFB'
+#if(UW)
+ DYNadv = 'UPW'
+#endif
+ no_vec = .true.
+ ntFlog = .false.
+ openLB = .false.
+ sommlb = .false.
+ ! SBLitr=.true. ==> SBL is iterated
+ SBLitr = .true.
+ tur_25 = .false.
+ ! +--CONSTANTS
+ ! + =========
+ ntracr = 0
+#if(TC)
+ ntracr = ntrac
+#endif
+ ! +--Grid Constants
+ ! + --------------
+ rxy = 1.e-6 / (mx * my)
+ m = mx
+ m1 = m - 1
+ m2 = m - 2
+ m3 = m - 3
+ m4 = m - 4
+ mn3 = mn - 3
+ mn4 = mn - 4
+
+ ttime = ' '
+ write(6, 6)
+ 6 format(&
+ /, " " &
+ , /, " *********************************** " &
+ , /, " * * " &
+ , /, " * MM MM AAAA RRRRRR * " &
+ , /, " * MMMM MMMM AA AA RR RR * " &
+ , /, " * MM MM MM AAAAAAAA RRRRRR * " &
+ , /, " * MM MM AA AA RR RR * " &
+ , /, " * MM MM AA AA RR RR * " &
+ , /, " * * " &
+ , /, " * Modele Atmospherique Regional * " &
+ , /, " * * " &
+ , /, " *********************************** " &
+ , /, " " &
+ , /, " - MARv3.13.0 - 13/12/2022 - " &
+ , /, " ")
+
+ !$ number_threads = omp_get_max_threads()
+
+ write(6, 7) " OMP CPU=", number_threads
+ write(6, 7) " mx=", mx
+ write(6, 7) " my=", my
+ write(6, 7) " mz=", mz
+ write(6, 7) " mw=", mw
+ write(6, 7) " nsno=", nsno
+ write(6, 7) " mzabso=", mzabso
+ write(6, 7) " mzhyd=", mzhyd
+ write(6, *) ""
+ write(6, 8) " humidity_magic=", humidity_magic
+ write(6, 8) " cloud_magic=", cloud_magic
+ write(6, 8) "correction_humidity_boundary=", correction_humidity_boundary
+ write(6, *) ""
+
+ if(cloud_magic < 0 .or. cloud_magic > 1 .or. humidity_magic < 0) then
+ print *, "error in cloud_magic [0,1] or humidity_magic [0,100]"
+ stop
+ endif
+
+ if(correction_humidity_boundary < -0.5 .or. correction_humidity_boundary > 0.5) then
+ print *, "error in correction_humidity_boundary [-0.5,0.5]"
+ stop
+ endif
+
+ if(klonv > 1 .or. klon > 1) then
+ print *, "klonv/klon must be = 1 in mar_sv_mod.f90/MARdim_mod.f90"
+ stop
+ endif
+
+ 7 format(a29, i4)
+ 8 format(a29, f6.2)
+
+ ! +--Machine Precision
+ ! + =================
+ rrmin = 0.1e-36
+ rrmax = 0.1e+38
+
+ ! +--Min and Max Arguments of Function exp(x)
+ ! + ----------------------------------------
+ argmin = log(rrmin)
+ iargum = argmin
+ i__min = iargum + 7
+ argmax = log(rrmax)
+ iargum = argmax
+ i__max = iargum - 8
+ ! write(6,600) argmin,i__min,argmax,i__max
+ ! 600 format(/, ' Function exp(x) : Arguments:', &
+ ! /, ' Minimum Value : ', e12.4, 5x, '==> (', i3, ')', &
+ ! /, ' Maximum Value : ', e12.4, 5x, '==> (', i3, ')')
+ argmin = i__min
+ argmax = i__max
+
+ ! +--PHYSICAL DATA
+ ! + =============
+ ! + ******
+ call phymar
+ ! + ******
+#if(iso)
+ ! iso constants
+ call mariso_constants
+#endif
+
+ ! +--CONTROL PARAMETERS
+ ! + ==================
+ open(unit = 3, status = 'old', file = 'MARctr.dat')
+ rewind 3
+ read(3, 31) reaVAR, reaLBC, safVAR
+ 31 format(l12)
+ if(.not. reaVAR) geoNST = .false.
+ ! hamfil: Initialisation based on Temporal Filtering (Hamming)
+ read(3, 31) hamfil
+ ! conmas: Initialis. Constrained (Mass Conservation)
+ read(3, 31) conmas
+ ! potvor: Initialis. Constrained (Potent. Vortic. Conservation)
+ read(3, 31) potvor
+ ! brocam: Brown and Campana Time Scheme Switch
+ read(3, 31) brocam
+ ! center=.T. => Pressure Spatial Scheme centered
+ read(3, 31) center
+ ! nordps= 4 : Pressure Spatial Scheme Precision
+ read(3, 32) nordps
+ ! staggr=.T. => Vertical Grid staggered
+ read(3, 31) staggr
+ 32 format(i12)
+ ! turhor=.T.: Horizontal Diffusion (Smagorinsky) Switch
+ read(3, 31) turhor
+ ! chimod=.F.: Atmospheric Chemical Model turned OFF
+ ! chimod=.T.: Atmospheric Chemical Model turned ON
+ read(3, 31) chimod
+ ! convec=.T.: Mass Flux convective Scheme turned ON
+ read(3, 31) convec
+ ! micphy=.F.: only the dry model is run
+ ! micphy=.T.: the explicit hydrological cycle is included
+ read(3, 31) micphy
+ ! fracld=.T.: Fraction.Cloudiness Scheme turned ON
+ read(3, 31) fracld
+ ! rhcrit_0: relative humidity critical saturation value
+ read(3, 43) rhcrit_0
+ ! rhcrHY: relative humidity critical saturation value
+ rhcrHY = rhcrit_0
+ !cCA:[TO DO] -> to be changed to accept supersaturation?
+ if(rhcrHY > 1.) then
+ write(6, 300) rhcrHY
+ 300 format(/, ' *********************************************************************', &
+ /, ' * Critical Humidity =', f6.2, ' [%] / new units: [-] => divide by 100 *', &
+ /, ' *********************************************************************', /, 1x)
+ rhcrHY = rhcrHY * 10.**(-2)
+ endif
+ read(3, 43) tstart_0
+ ! tim_HY: hydrological cycle starting time (prefarably uses 0.)
+ tim_HY = tstart_0
+ 43 format(f12.4)
+ ! cz0_GE : Cosine of Solar Zenith Angle (Minimum Value for solari call)
+ read(3, 34) cz0_GE
+ 34 format(d12.4)
+ ! physic: Physics are included
+ read(3, 31) physic
+ ! vegmod =.true. : Interactive SVAT turned ON
+ read(3, 31) vegmod
+ if(.not. physic) vegmod = .false.
+ ! snomod =.true. : Interactive Snow Model turned ON
+ read(3, 31) snomod
+ if(.not. physic) snomod = .false.
+ ! polmod =.true. : Interactive Polynya Dynamics turned ON
+ read(3, 31) polmod
+ ! hic0 : assumed initial sea-ice Thickness
+ read(3, 43) hic0
+ ! fxlead : assumed initial minimal Leads Fraction
+ read(3, 43) fxlead
+ ! qsolSL: Deardorff model for soil humidity
+ read(3, 31) qsolSL
+ read(3, 43) dt
+ dt_inv = 1.0 / dt
+ ! nboucl : nb of time steps between each print
+ read(3, 32) nboucl
+ read(3, 32) nprint
+ read(3, 32) ntFast
+ if(mod(ntFast, 2) == 0) then
+ write(6, 301) ntFast
+ 301 format(/, ' *******************************************************************', &
+ /, ' * Value of ntFast =', i6, ' is even (precluded) =====> 1 is added *', &
+ /, ' *******************************************************************', /, 1x)
+ ! Fixed ntFast
+ ntFast = ntFast + 1
+ endif
+ ! XF no usefull to have ntFast=3
+ ntFast = 1
+ itexpe = 0
+ ! variable nt_Mix
+ nt_Mix = 3
+ nt_Mix_min = 1
+ nt_Mix_nbr = 0
+ nt_smooth = 0
+ ! dtDiff : Calibrated Subgrid Scale Time Step
+ read(3, 43) dtDiff
+ ! dtPhys : Surface Physics Time Step
+ read(3, 43) dtPhys
+ ! dtRadi : Radiation Time Step
+ read(3, 43) dtRadi
+ ! rxbase : Nudging Coefficient
+ read(3, 34) rxbase
+ ! rxfact : Lateral Sponge Coefficient
+ read(3, 34) rxfact
+ close(unit = 3)
+
+ ! +--New Control Parameters
+ ! + ----------------------
+#if(NH)
+ ! +--Non-Hydrostatic Dynamics
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~
+ ! csnd: Prescribed Sound Speed (m/s)
+ csnd = 330.
+ c2NH = csnd * csnd
+#endif
+ ! +--Chemical Model
+ ! + ~~~~~~~~~~~~~~
+ lotrac = 0
+#if(TC)
+ lotrac = 1
+ jtAdvH = 1
+ dtAdvH = dt
+ jt_ODE = 1
+ if(.not. chimod) then
+ dt_ODE = dt
+ jt_ODE = 1
+ nt_ODE = 1
+ ikTC(1) = 1
+ endif
+#endif
+ ! +--Print Characteristic
+ ! + --------------------
+ if(nprint < 0) then
+ nprint = -nprint
+ log_nc = 1
+ else
+ log_nc = 0
+ endif
+ ! ipr_nc (npr_nc): Netcdf Output File: Current No (Total Nb) of Prints
+ ipr_nc = 0
+ npr_nc = 1 + nprint
+ nterun = nboucl * nprint
+#if(AO)
+ !$OMP BARRIER
+ !$OMP MASTER
+ ! +-- Initialize coupling (cpl)
+ ! + ==========================
+ coupling_ao = .false.
+ write(6, *) 'Initialize coupling in MAR'
+ ! inicma : Define coupling fields in MAR
+ ! coupling_ao => .true.
+ ! + *****
+ call inicma
+ ! + *****
+ if(coupling_ao) then
+ write(6, *) 'Coupling initialization done in MAR'
+ write(6, *) coupling_ao
+ ! else
+ ! write(6,*) 'error in coupling init', coupling_ao
+ ! stop
+ endif
+ !$OMP END MASTER
+ !$OMP BARRIER
+#endif
+ ! +--OUTPUT Files
+ ! + ============
+ open(unit = 4, status = 'replace', file = 'MARphy.out')
+ rewind 4
+ open(unit = 21, status = 'new', file = 'MAR.log')
+ rewind 21
+
+ ! +--Katabatic Jump Diagnostics
+ ! + --------------------------
+ if(mx > 1 .and. my <= 1) then
+ open(unit = 22, status = 'unknown', file = 'MAR.uuu')
+ rewind 22
+ open(unit = 23, status = 'unknown', file = 'MAR.ttt')
+ rewind 23
+ open(unit = 24, status = 'unknown', file = 'MAR.ppp')
+ rewind 24
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ INITIALISATION +++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ !$OMP BARRIER
+ !$OMP MASTER
+ ! + ******
+ call inigen
+ ! + ******
+ !$OMP END MASTER
+ !$OMP BARRIER
+ if(track_wind) then
+ call trackwind_init()
+ endif
+ if (track_dgz) then
+ call trackdgz_init()
+ end if
+ if(track_water) then
+ ! allocate and set water budget variables to zero before time loop
+ call trackwater_init()
+ end if
+
+#if(iso)
+ ! iso outputs
+ call mariso_create_file
+ ! initialize output file time increment
+ iso_time = 1
+ iso_label = 'create '
+ call mariso_write_file(iso_time, iso_label) ! 1
+#endif
+
+ ! +--PBL Initialization Parameter
+ ! + ============================
+ if(itexpe <= 0) then
+ log_1D = 0
+ else
+ log_1D = 1
+ endif
+
+ ! +--HAMMING Filter Parameters
+ ! + =========================
+ iham = 0
+ nham = 0
+
+ ihamr = iham
+ nhamr = nham
+
+ ! +--Domain Averaged Pressure Thickness
+ ! + ==================================
+ pav = 0.
+ do j = 1, my
+ do i = 1, mx
+ pav = pav + pstDYn(i, j)
+ enddo
+ enddo
+ pav = pav / (mx * my)
+
+ ! +--OUTPUT
+ ! + ======
+ if(IO_loc >= 2) then
+ do i = 1, 5
+ tta(i) = tsrfSL(igrdIO(i), jgrdIO(i), 1) - TfSnow
+ enddo
+ write(21, 607)(igrdIO(i), jgrdIO(i), i = 1, 5), &
+ (sh(igrdIO(i), jgrdIO(i)), tta(i), i = 1, 5)
+ 607 format(//, 5(5x, ' (', i4, ',', i4, ')', 5x, '!! '), &
+ /, 5(' altitude ! temperat. ', '!! '), &
+ /, 5(10('-'), '!', 11('-'), '!!-'), &
+ /, 5(f8.1, ' ! ', f8.2, ' !! '))
+ do kk = 1, mz
+ k = mz + 1 - kk
+ do i = 1, 5
+ zza(i) = gplvDY(igrdIO(i), jgrdIO(i), k) * grvinv
+ tta(i) = pktaDY(igrdIO(i), jgrdIO(i), k) * pcap
+ enddo
+ write(21, 609)(zza(i), tta(i), i = 1, 5)
+ 609 format(5(f8.1, ' ! ', f8.2, ' !! '))
+ enddo
+ write(21, 611)
+ 611 format(1x)
+ endif
+
+ if(mmx > 1 .and. mmy <= 1) then
+ write(22, 221) itexpe, (xxkm(i), i = imez - 10, imez + 30)
+ write(23, 221) itexpe, (xxkm(i), i = imez - 10, imez + 30)
+ write(24, 221) itexpe, (xxkm(i), i = imez - 10, imez + 30)
+ endif
+
+ ! +--NetCDF Files
+ ! + ------------
+ nbhour = 0
+ do while(mod(3600 * nbhour, idt) /= 0)
+ !cCA 1 continue
+ nbhour = nbhour + 1
+ enddo
+ !cCA if (mod(3600 * nbhour, idt)/=0) go to 1
+ if(log_nc == 1) then
+ dt_Loc = dt
+ ipr_nc = ipr_nc + 1
+ ! + ******
+ call out_nc(ipr_nc)
+ ! + ******
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of the EXTERNAL TIME INCREMENTATION (nprint over dt * nboucl) ++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ do iprint = 0, nprint - 1
+ ! +--Output Files Label
+ ! + ==================
+ fnam(1:3) = 'si_'
+ jmmd = 1 + mod(minuGE, 10)
+ jm10 = 1 + minuGE / 10
+ jh10 = 1 + jhaMAR / 10
+ jh1 = 1 + mod(jhaMAR, 10)
+ jd10 = 1 + jdaMAR / 10
+ if(jd10 > 10) then
+ fnam(3:3) = '+'
+ jd10 = mod(jd10, 10)
+ endif
+ jd1 = 1 + mod(jdaMAR, 10)
+ fnam(4:4) = labnum(jd10)
+ fnam(5:5) = labnum(jd1)
+ fnam(6:6) = labnum(jh10)
+ fnam(7:7) = labnum(jh1)
+ fnam(8:8) = labnum(jm10)
+ fnam(9:9) = labnum(jmmd)
+ fnam(10:10) = '.'
+ fnam(11:13) = explIO
+ fnam(14:16) = ' '
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of the INTERNAL TIME INCREMENTATION (nboucl over dt) +++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ !cCA iboucl = 1
+ !cCA 2 continue
+ do iboucl = 1, nboucl
+#if(AO)
+ ! +--cpl : GET FIELDS FROM OASIS
+ ! + ===========================
+ !$OMP BARRIER
+ !$OMP MASTER
+ ! + ***********
+ call OASIS_2_MAR
+ ! + ***********
+ !$OMP END MASTER
+ !$OMP BARRIER
+#endif
+#if(SB)
+ ! +--Modification of the Surface Forcing
+ ! + ===================================
+ ! + ******
+ call sbcnew
+ ! + ******
+#endif
+#if(iso)
+ iso_label = 'sbcnew '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label) ! 2
+#endif(iso)
+
+ ! + ******
+ call filatmo
+ ! + ******
+
+ if(iterun <= 1 .or. mod(iterun, 6 * 3600 / int(dt)) == 0) call time_steps
+
+ if(itexpe <= 1) then
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, mw
+ if(ivegTV(i, j, k) > nvgt .or. ivegTV(i, j, k) < 0) then
+ print *, "Error in vegetation type", i, j, k, ivegTV(i, j, k)
+ print *, "Have you initialized your snowpack ?"
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of DIABATIC INITIALISATION +++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ if(mmx > 1 .and. log_1D == 1) then
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of FAST PROPAGATING WAVES DYNAMICS (HYDROSTATIC PART) ++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +...``Dynamics'' is active only after the 1-D Initialisation Phase
+ ! +--Update of Horizontal Wind Speed and Mass
+ ! + ========================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ubefDY(i, j, k) = uairDY(i, j, k)
+ vbefDY(i, j, k) = vairDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ pstDY(i, j) = pstDYn(i, j)
+ opstDY(i, j) = pstDYn(i, j)
+ enddo
+ enddo
+
+ ! +--Update of nt_Mix parameter (CFL criterion on Max Wind Speed)
+ ! + ============================================================
+ if(.not. ntFlog) then
+ ntFlog = .true.
+ ! CFLinv : Inverse CFL Number
+ CFLinv = dt / dx
+ ! rtFact : Sound Speed upper Bound (500m/s) normalized by the CFL Number
+ rtFact = 500.0 * CFLinv
+ ! +--Local Wind Speed
+ ! + ----------------
+ VLocmx = 0.
+ TLocmn = 273.15
+ iLocmx = 0
+ jLocmx = 0
+ kLocmx = 0
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = (abs(uairDY(i, j, k)) &
+ + min(1, my - 1) * abs(vairDY(i, j, k)))
+ enddo
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ VLocmx = max(VLocmx, WKxyz1(i, j, k))
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ TLocmn = min(TLocmn, tairDY(i, j, mz - 1))
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ if(WKxyz1(i, j, k) > VLocmx - epsi) then
+ iLocmx = i
+ jLocmx = j
+ kLocmx = k
+ endif
+ enddo
+ enddo
+ enddo
+
+ TLocmn = TLocmn - 273.15
+ nt_sig = 1 + CFLzDY / ntFast
+ nt_BAK = nt_Mix
+ nt_Mix = max(nt_sig, int(rtFact + CFLinv * VLocmx))
+ nt_Mix = max(3, nt_Mix)
+ if(itexpe < 100) nt_Mix = max(8, nt_Mix)
+
+ dtFast = dt / ((ntFast + 1) * nt_Mix) ! see inigen
+ FIfstu = FIslou / ((ntFast + 1)) ! see grdmar
+ FIfstp = FIslop / ((ntFast + 1)) ! see grdmar
+ do k = 1, mz
+ FIk_fu(k) = max(FIk_fu(k), FIfstu / max(0.1, sigma(k))) ! see grdmar
+ FIk_fp(k) = max(FIk_fp(k), FIfstp / max(0.1, sigma(k))) ! see grdmar
+ enddo
+
+ write(6, 1001) &
+ TLocmn, VLocmx, iLocmx, jLocmx, kLocmx &
+ , nt_BAK, nt_Mix, itexpe &
+ , jdarGE, labmGE(mmarGE), iyrrGE &
+ , jhurGE, minuGE, jsecGE
+ 1001 format('WARNING: TT min =', f8.2, &
+ ' S(|V|)max =', f8.1, ' (', 3i4, ')', &
+ ' ==> update nt_Mix(=', i4, ');:=', i4, ' at iteration', i8, &
+ ' Time is ', i2, '-', a3, '-', i4, &
+ '/', i2, '.', i2, '.', i2, ' UT')
+ endif
+
+ ! +--Begin of the Fast Time Loop
+ ! + ===========================
+
+ nt_tmp1 = max(2, min(5, nt_Mix / 2 + 1))
+ nt_tmp2 = max(1, min(3, ntFast / 2 + 1))
+
+ do it_Mix = 1, nt_Mix
+ do itFast = 1, ntFast + 1
+ if(.not. brocam) then
+ ! +--Integration of the Hydrostatic Relation
+ ! + =======================================
+ ! cCA : in classic config, brocam = .true., we don't go here
+ ! + ******
+ call dyngpo_mp
+ ! + ******
+ ! + WARNING : Place of this routine DYNgpo in the organigram depends
+ ! + if Brown-Campana (1978, MWR, p.1125) time scheme is used or not!
+ ! + Here is the place when the Brown-Campana time scheme is not used.
+ endif
+ ! +--Mass Continuity
+ ! + ===============
+ norder_0 = nordps
+ ! + ******
+ call DYNdps_mp(norder_0)
+ ! + ******
+
+ ! +--Filtering
+ ! + ---------
+ if(FIfstp > 0. .and. mod(it_mix, nt_tmp1) == 0) then
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, 1) = pstDYn(i, j) - pstDY1(i, j)
+ enddo
+ enddo
+ dumeps(1) = FIfstp
+ kdim = 1
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + *********
+ call DYNfil_3D(dumy3D, dumeps, kdim)
+ ! + *********
+ endif
+ do j = 1, my
+ do i = 1, mx
+ pstDYn(i, j) = dumy3D(i, j, 1) + pstDY1(i, j)
+ enddo
+ enddo
+ endif
+
+ if(brocam) then
+ ! +--Integration of the Hydrostatic Relation
+ ! + =======================================
+ ! cCA : in classic config, brocam = .true.
+ ! + WARNING : The place of routine DYNgpo in the organigram depends
+ ! + if Brown-Campana (1978, MWR, p.1125) time scheme is used or not!
+ ! + Here is the place when Brown-Campana time scheme is used.
+ ! + *********
+ if(itFast == 1 .and. it_mix == 1) call dyngpo_mp
+ ! + *********
+ endif
+
+ ! +--Contribution of Horizontal Pressure Gradient Force
+ ! + ==================================================
+ if(track_wind) then
+ uairDY_save = uairDY
+ vairDY_save = vairDY
+ ! track_wind also inside dyndgz_mp with track_dgz
+ endif
+ norder_0 = nordps
+ ! + **********
+ call dyndgz_mp(norder_0)
+ ! + **********
+
+ if(track_wind) then
+ delta_u(:, :, :, i_dyndgz) = delta_u(:, :, :, i_dyndgz) + (uairDY - uairDY_save)
+ delta_v(:, :, :, i_dyndgz) = delta_v(:, :, :, i_dyndgz) + (vairDY - vairDY_save)
+ endif
+
+ if(itFast == nt_tmp2) then
+ ! +--Filtering of the Horizontal Wind Speed Components
+ ! + =================================================
+ if(FIk_fu(1) > 0.0 .and. mod(it_Mix, nt_tmp1) == 0) then
+ if(mmy <= 1) stop
+ do k = 1, mz
+ dumeps(k) = FIk_fu(k)
+ enddo
+ kdim = mz
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = uairDY(i, j, k)
+ if(track_wind) then
+ uairDY_save(i, j, k) = uairDY(i, j, k)
+ endif
+ enddo
+ enddo
+ enddo
+ ! + ************
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + ************
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ uairDY(i, j, k) = dumy3D(i, j, k)
+ dumy3D(i, j, k) = vairDY(i, j, k)
+ if(track_wind) then
+ delta_u(i, j, k, i_dynfil) = delta_u(i, j, k, i_dynfil) + &
+ (uairDY(i, j, k) - uairDY_save(i, j, k))
+ vairDY_save(i, j, k) = vairDY(i, j, k)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! + ************
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + ************
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ vairDY(i, j, k) = dumy3D(i, j, k)
+ if(track_wind) then
+ delta_v(i, j, k, i_dynfil) = delta_v(i, j, k, i_dynfil) + &
+ (vairDY(i, j, k) - vairDY_save(i, j, k))
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ else
+ if(itFast == ntFast + 1) then
+ ! +--Filtering of the Vertical H Wind Speed Component
+ ! + ================================================
+ if(FIk_fp(1) > 0.0 .and. mod(it_Mix, nt_tmp1) == 0) then
+ if(mmy <= 1) then
+ do k = 1, mz
+ do i = 1, mx
+ dumy3D(i, 1, k) = psigDY(i, 1, k)
+ enddo
+ dumeps(k) = FIk_fp(k)
+ enddo
+ kdim = mz
+
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+
+ ! + The PGF does not contribute to v in the 2-D version
+ ! + making the filtering of v unnecessary.
+ do k = 1, mz
+ do i = 1, mx
+ psigDY(i, 1, k) = dumy3D(i, 1, k)
+ enddo
+ enddo
+ else
+ do k = 1, mz
+ dumeps(k) = FIk_fp(k)
+ enddo
+ kdim = mz
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = psigDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ psigDY(i, j, k) = dumy3D(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+ endif
+ endif
+ enddo
+ enddo
+#if(iso)
+ iso_label = 't_loop '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label) ! 4
+#endif(iso)
+ ! +--Update of nt_Mix parameter (CFL criterion on Max Wind Speed)
+ ! + ============================================================
+ ! +--Local Wind Speed
+ ! + ----------------
+ VLocmx = 0.
+ TLocmn = 273.15
+ iLocmx = 0
+ jLocmx = 0
+ kLocmx = 0
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = (abs(uairDY(i, j, k)) &
+ + min(1, my - 1) * abs(vairDY(i, j, k)))
+ enddo
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ VLocmx = max(VLocmx, WKxyz1(i, j, k))
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ TLocmn = min(TLocmn, tairDY(i, j, mz - 1))
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ if(WKxyz1(i, j, k) > VLocmx - epsi) then
+ iLocmx = i
+ jLocmx = j
+ kLocmx = k
+ endif
+ enddo
+ enddo
+ enddo
+
+ TLocmn = TLocmn - 273.15
+ nt_sig = 1 + CFLzDY / ntFast
+ nt_BAK = nt_Mix
+ nt_Mix = max(nt_sig, int(rtFact + CFLinv * VLocmx))
+ nt_Mix = max(nt_Mix, nt_BAK - 1)
+ nt_Mix = max(nt_Mix, nt_Mix_min)
+ if(nt_mix > 10 .and. ntFast == 1) then
+ ntFast = 3
+ nt_Mix = 4
+ nt_BAK = 4
+ endif
+ if(nt_mix > 10 .and. ntFast == 3) then
+ ntFast = 5
+ nt_Mix = 4
+ nt_BAK = 4
+ endif
+ if(nt_mix > 20) stop 'Nt_mix is too high !! MAR is too instable !!'
+
+ nt_smooth = max(0, nt_smooth - 1)
+ ! nt_Mix can not decrease during at least 15 min
+ if(nt_smooth > 0) nt_Mix = max(nt_Mix, nt_BAK)
+ if(nt_Mix /= nt_BAK) then
+ nt_smooth = sqrt(real(nt_Mix)) * 900. / dt ! 15 min
+ nt_smooth = max(nt_smooth, 15)
+ dtFast = dt / ((ntFast + 1) * nt_Mix) ! see inigen
+ FIfstu = FIslou / ((ntFast + 1)) ! see grdmar
+ FIfstp = FIslop / ((ntFast + 1)) ! see grdmar
+
+ if(ntFast == 1) then
+ do k = 1, mz
+ FIk_fu(k) = max(FIk_fu(k), FIfstu / max(0.1, sigma(k))) ! see grdmar
+ FIk_fp(k) = max(FIk_fp(k), FIfstp / max(0.1, sigma(k))) ! see grdmar
+ enddo
+ else
+ do k = 1, mz
+ FIk_fu(k) = FIfstu / max(0.1, sigma(k)) ! see grdmar
+ FIk_fp(k) = FIfstp / max(0.1, sigma(k)) ! see grdmar
+ enddo
+ endif
+
+ if(nt_Mix > nt_BAK) then
+ do i = 1, nt_BAK
+ nt_Mix_nbr(i) = nt_Mix_nbr(i) + 1
+ if(nt_Mix_nbr(i) > 3) nt_Mix_min = min(4, i + 1)
+ enddo
+ write(6, 1001) &
+ TLocmn, VLocmx, iLocmx, jLocmx, kLocmx &
+ , nt_BAK, nt_Mix, itexpe &
+ , jdarGE, labmGE(mmarGE), iyrrGE &
+ , jhurGE, minuGE, jsecGE
+ endif
+ endif
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of FAST PROPAGATING WAVES DYNAMICS (HYDROSTATIC PART) ++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#if(NH)
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of FAST PROPAGATING WAVES DYNAMICS (NON-HYDROSTATIC PART) ++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Non-Hydrostatic Dynamics
+ ! + ========================
+ ! + ******
+ call DYN_NH
+ ! + ******
+ ! +--Filtering
+ ! + ---------
+ ! + *********
+ call DYNfil_NH
+ ! + *********
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of FAST PROPAGATING WAVES DYNAMICS (NON-HYDROSTATIC PART) ++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#endif
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of SLOW PROPAGATING WAVES DYNAMICS +++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Advection
+ ! + =========
+
+ ! +--Leapfrog Backward Scheme
+ ! + ------------------------
+ if(DYNadv == 'LFB') then
+ ! cCA : in classic config, DYNadv == 'LFB'
+ if(track_water) then
+ qvDY_save = qvDY
+ endif
+#if(iso)
+ iso_label = 'LFB__0 '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label) ! 5
+#endif(iso)
+ norder_0 = nordps
+ ! + **********
+ call DYNadv_LFB(norder_0)
+ ! + **********
+ if(track_water) then
+ delta_qv(:, :, :, j_dynadv) = delta_qv(:, :, :, j_dynadv) + (qvDY - qvDY_save)
+ endif
+#if(iso)
+ iso_label = 'LFB__1 '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ endif
+
+ ! +--Forward Scheme
+ ! + --------------
+ if(DYNadv == 'UPW') then
+ ! cCA : in classic config, DYNadv == 'LFB'
+ ! +--Vertical Advection: (Thermo)Dynamics
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + **********
+ call DYNadv_ver
+ ! + **********
+
+ ! +--Vertical Advection: Water Species
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(.not. micphy) then
+ ! + ***********
+ call DYNadv_verq
+ ! + ***********
+
+ else
+ ! + **********
+ call HYDadv_ver
+ ! + **********
+
+ endif
+#if(TC)
+ ! +--Vertical Advection: Tracers
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + **********
+ call TRCadv_ver
+ ! + **********
+#endif
+ ! +--Horizontal Advection: Momentum
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ FirstC = .false.
+ qqmass = .false.
+ ! + **********
+ call DYNadv_hor(qqmass, uairDY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ ! + **********
+ call DYNadv_hor(qqmass, vairDY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ ! +--Horizontal Advection: (Thermo)dynamics
+ ! + ~~~~~~~~~~~~~~~~~~~~~ Water Species
+ ! + ~~~~~~~~~~~~~~~~
+ FirstC = .true.
+ qqmass = .true.
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! + **********
+ call DYNadv_hor(qqmass, dumy3D, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, k) = dumy3D(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ FirstC = .false.
+
+ ! + **********
+ call DYNadv_hor(qqmass, qvDY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ if(micphy) then
+
+ ! + **********
+ call DYNadv_hor(qqmass, ccniHY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ ! + **********
+ call DYNadv_hor(qqmass, qiHY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ ! + **********
+ call DYNadv_hor(qqmass, qsHY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ ! + **********
+ call DYNadv_hor(qqmass, qwHY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ ! + **********
+ call DYNadv_hor(qqmass, qrHY, opstDY, pstDYn, uairDY, vairDY)
+ ! + **********
+
+ endif
+#if(BS)
+ ! +--Horizontal Advection: Saltating Snow
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + **********
+ call DYNadv_sal
+ ! + **********
+#endif
+#if(TC)
+ ! +--Horizontal Advection: Tracers
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(mod(itexpe, jtAdvH) == 0) then
+ qqmass = .true.
+ ! + **********
+ call TRCadv_hor
+ ! + **********
+ ! +--New Time Step
+ ! + ~~~~~~~~~~~~~
+ cfladv = epsi
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ cfladv = max(cfladv, abs(uairDY(i, j, k)))
+ cfladv = max(cfladv, abs(vairDY(i, j, k)))
+ enddo
+ enddo
+ enddo
+ dtAdvH = demi * dx / cfladv
+ dtAdvH = min(dtAdvH, dt_ODE)
+ dtAdvH = max(dtAdvH, dt)
+ ! jtAdvH : Number of Dynamical Steps for 1 Advection Step
+ jtAdvH = dtAdvH / dt
+ ! dtAdvH : Calibrated Advection Time Step
+ dtAdvH = dt * jtAdvH
+ ntAdvH = 1
+ endif
+#endif
+ endif
+
+ ! +--Rayleigh Friction (Ref. ARPS 4.0 User's Guide, para 6.4.3 p.152)
+ ! + =================
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, k) = (pktaDY(i, j, k) + Ray_UB(k) * dt * pktaUB(i, j, k) &
+ / min(10, max(1, k - mzhyd + 2))) &
+ / (1.0 + Ray_UB(k) * dt / min(10, max(1, k - mzhyd + 2)))
+
+ enddo
+ enddo
+ enddo
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of SLOW PROPAGATING WAVES DYNAMICS +++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ else !cCA not(if (mmx > 1 .and. log_1D == 1))
+ !cCA +++++++++++++++++++++++++++++++++++++++++++++++++++
+ !cCA First initialization (log_1D == 0) ++++++++++++++++
+ !cCA +++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! + ******
+ call dyngpo_mp
+ ! + ******
+
+ ! +--Mid-Level Geopotential
+ ! + ----------------------
+ k = 1
+ do j = 1, my
+ do i = 1, mx
+ gpmiDY(i, j, k) = 0.5 * (3.5 * gplvDY(i, j, 1) - 0.5d0 * gplvDY(i, j, 2))
+ enddo
+ enddo
+
+ do k = kp1(1), mz
+ do j = 1, my
+ do i = 1, mx
+ gpmiDY(i, j, k) = 0.5 * (gplvDY(i, j, k - 1) + gplvDY(i, j, k))
+ enddo
+ enddo
+ enddo
+
+ k = mzz
+ do j = 1, my
+ do i = 1, mx
+ gpmiDY(i, j, k) = (0.5 * z__SBL + sh(i, j)) * gravit
+ enddo
+ enddo
+ !cCA +++++++++++++++++++++++++++++++++++++++++++++++++++
+ !cCA END of First initialization (log_1D == 0) +++++++++
+ !cCA +++++++++++++++++++++++++++++++++++++++++++++++++++
+ endif
+
+ ! +--Specific Mass
+ ! + =============
+ ! + ******
+ call dynrho
+ ! + ******
+
+ ! +--Saturation Specific Humidity
+ ! + ============================
+ ! + ******
+ call qsat3d
+ ! + ******
+
+ ! +--Vertical Velocity in Cartesian Coordinates
+ ! + ==========================================
+ if(convec .and. mmx > 1) then
+ ! + ******
+ call dynwww
+ ! + ******
+ endif
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of MAR "SUBGRID ZONE" (INCLUDING CORIOLIS FORCE) +++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Local Temporal Parameters
+ ! + =========================
+
+ if(log_1D == 0 .and. tequil > 0.) then
+ ! +--Boundary Layer Initialisation over time tequil
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ tequil = tequil * 3600.
+ ! +... Conversion [h]->[s]
+ dt_Loc = dtquil
+ nt_Loc = tequil / dtquil
+ jt_Loc = 1
+ else
+ ! +--Boundary Layer is iterated over time dt
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dt_Loc = dtDiff
+ nt_Loc = ntDiff
+ jt_Loc = jtDiff
+ endif
+
+ ! +--Begin of Subgrid Loop
+ ! + =====================
+ if(mod(itexpe, jt_Loc) == 0) then
+ do it_Loc = 1, nt_Loc
+ ! +--Coriolis Force Contribution (Implicit Scheme)
+ ! + ---------------------------------------------
+ if(track_wind) then
+ uairDY_save = uairDY
+ vairDY_save = vairDY
+ endif
+
+ do i = 1, mx
+ do j = 1, my
+ do k = 1, mz
+ uairDY(i, j, k) = uairDY(i, j, k) &
+ + fcorDY(i, j) * (vairDY(i, j, k) - vgeoDY(i, j, k)) * dt_Loc
+ vairDY(i, j, k) = vairDY(i, j, k) &
+ - fcorDY(i, j) * (uairDY(i, j, k) - ugeoDY(i, j, k)) * dt_Loc
+ enddo
+ enddo
+ enddo
+
+ if(track_wind) then
+ delta_u(:, :, :, i_coriol) = delta_u(:, :, :, i_coriol) + (uairDY - uairDY_save)
+ delta_v(:, :, :, i_coriol) = delta_v(:, :, :, i_coriol) + (vairDY - vairDY_save)
+ endif
+
+ ! +--Horizontal Subgrid Processes
+ ! + ----------------------------
+ if(turhor .and. log_1D == 1 .and. mmx > 1) then
+ ! +--Horizontal Diffusion Coefficient
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + *********
+ call turhor_kh
+ ! + *********
+
+ ! +--Contribution of Horizontal Diffusion
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(track_wind) then
+ uairDY_save = uairDY
+ vairDY_save = vairDY
+ endif
+ if(track_water) then
+ qvDY_save = qvDY
+ end if
+ ! + **********
+ call turhor_dyn(dtDifH)
+ ! + **********
+ if(track_wind) then
+ delta_u(:, :, :, i_turhor) = delta_u(:, :, :, i_turhor) + (uairDY - uairDY_save)
+ delta_v(:, :, :, i_turhor) = delta_v(:, :, :, i_turhor) + (vairDY - vairDY_save)
+ endif
+ if(track_water) then
+ delta_qv(:, :, :, j_turhor) = delta_qv(:, :, :, j_turhor) + (qvDY - qvDY_save)
+ endif
+#if(iso)
+ iso_label = 'turhor_dyn'
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ endif
+ ! +--Water Vapor and Precipitation Loading
+ ! + -------------------------------------
+ ! + ******
+ call dynloa
+ ! + ******
+
+ ! +--Vertical Subgrid Processes
+ ! + --------------------------
+ if(dtDiff > 0.) then
+ ! +--Turbulent Kinetic Energy
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~
+ if(jt_Loc > 1) then
+ dtLLoc = min(dt_Loc, dtAdvH)
+ ! CAUTION: dtDifH computed in turhor_dyn
+ dtLLoc = min(dtLLoc, dtDifH)
+ dtLLoc = max(dtLLoc, dt)
+ ntLLoc = dt_Loc / dtLLoc
+ ntLLoc = max(ntLLoc, iun)
+ dtLLoc = dt_Loc / ntLLoc
+ else
+ dtLLoc = dt_Loc
+ ntLLoc = 1
+ endif
+ do itLLoc = 1, ntLLoc
+ ! + ****************
+ if(mmx > 1) call turtke_advh(dtLLoc)
+ if(mmx > 1) call turtke_advv(dtLLoc)
+ if(mmx > 1) call turtke_difh(dtLLoc)
+ call turtke_difv(dtLLoc, 0.)
+ call turtke_gen(dtLLoc)
+ ! + ***************
+ enddo
+
+ ! +--Surface Layer
+ ! + ~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ssvSL(i, j, k) = sqrt(max(uairDY(i, j, k) * uairDY(i, j, k) &
+ + vairDY(i, j, k) * vairDY(i, j, k) &
+ , epsi))
+ enddo
+ enddo
+ enddo
+
+ itConv = itexpe * nt_Loc / jt_Loc + it_Loc
+ ! if (convec.and.itexpe*dt> 24*3600) then
+
+ ! end if
+
+ ! +--Contribution of Turbulent Vertical Diffusion
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(track_wind) then
+ uairDY_save = uairDY
+ vairDY_save = vairDY
+ endif
+ if(track_water) then
+ qvDY_save = qvDY
+ endif
+ ! + ******
+ call TURabl
+ ! + ******
+ if(track_wind) then
+ delta_u(:, :, :, i_turabl) = delta_u(:, :, :, i_turabl) + (uairDY - uairDY_save)
+ delta_v(:, :, :, i_turabl) = delta_v(:, :, :, i_turabl) + (vairDY - vairDY_save)
+ endif
+ if(track_water) then
+ delta_qv(:, :, :, j_turabl) = delta_qv(:, :, :, j_turabl) + (qvDY - qvDY_save)
+ endif
+
+#if(iso)
+ ! todo : qi, qw, qr, qs, rain, snow, ...
+ iso_label = 'turabl '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ if(track_water) then
+ qvDY_save = qvDY
+ endif
+ ! + ******
+ call sspray
+ ! + ******
+ if(track_water) then
+ delta_qv(:, :, :, j_sspray) = delta_qv(:, :, :, j_sspray) + (qvDY - qvDY_save)
+ endif
+#if(iso)
+ iso_label = 'sspray '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+#if(NH)
+ ! +--Contribution of Turbulent Vertical Diffusion (Non Hydrostatic Variables)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call TURvNH
+ ! + ******
+#endif
+ endif
+ enddo
+ endif
+
+#if(TC)
+ ! +--Tracers Turbulent Transfert
+ ! + ===========================
+ if(dt_ODE /= dtDiff) then
+ if(mod(itexpe, jt_ODE) == 0) then
+ dt_Loc = dt_ODE
+ nt_Loc = nt_ODE
+ do it_Loc = 1, nt_Loc
+ ! + *********
+ call TURabl_TC
+ ! + *********
+ enddo
+ endif
+ endif
+#endif
+
+ ! +--Initialized Temperature Vertical Profiles
+ ! + =========================================
+ if(IO_loc >= 2 .and. log_1D == 0) then
+ do i = 1, 5
+ tta(i) = tsrfSL(igrdIO(i), jgrdIO(i), 1) - TfSnow
+ enddo
+ write(21, 607)(igrdIO(i), jgrdIO(i), i = 1, 5), &
+ (sh(igrdIO(i), jgrdIO(i)), tta(i), i = 1, 5)
+ do kk = 1, mz
+ k = mzz - kk
+ do i = 1, 5
+ zza(i) = gplvDY(igrdIO(i), jgrdIO(i), k) * grvinv
+ tta(i) = pktaDY(igrdIO(i), jgrdIO(i), k) * pcap
+ enddo
+ write(21, 609)(zza(i), tta(i), i = 1, 5)
+ enddo
+ write(21, 611)
+ endif
+ ! log_1D = 1 <==> PBL initialisation is performed
+ log_1D = 1
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of MAR "SUBGRID ZONE" (INCLUDING CORIOLIS FORCE) +++++++++++++++
+ ! +++ EXPLICIT HYDROLOGICAL CYCLE +++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Cloud Microphysical Processes
+ ! + =============================
+ if(micphy) then
+ if(track_water) then
+ qvDY_save = qvDY
+ endif
+ ! + ******
+ call HYDgen
+ ! + ******
+ if(track_water) then
+ delta_qv(:, :, :, j_hydgen) = delta_qv(:, :, :, j_hydgen) + (qvDY - qvDY_save)
+ endif
+#if(iso)
+ iso_label = 'hydgen '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ else
+ ! +--Elimination of Water Vapor in Excess
+ ! + ====================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qvDY(i, j, k) = max(zero, qvDY(i, j, k))
+ qvDY(i, j, k) = min(qvswDY(i, j, k), qvDY(i, j, k))
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ BEGIN of LATERAL BOUNDARY CONDITIONS and FILTERING +++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +--Modification of the External Forcing
+ ! + ====================================
+ if(mmx > 1) then
+ if(reaLBC) then
+ ! +--LBC are provided by a Large Scale (3-D) Model
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call INIlbc(ihamr, nhamr, newlbc_0)
+ call INIubc(ihamr, nhamr, newlbc_0)
+ ! + ******
+ ! + **********
+ if(newlbc_0 == 1) call lbcnud_par
+ ! + **********
+ else
+ ! +--LBC are provided by one Sounding (Horizontal Homogeneity is assumed)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call inisnd
+ ! + ******
+
+ ! + **********
+ call lbcnud_par
+ ! + **********
+ endif
+
+ ! +--Lateral Boundary Conditions for Mass Continuity p*
+ ! + ("Nudging" Type / Davies, QJRMS, 1976, pp.405--418)
+ ! + ("Open" Lateral Boundary Condition is possible)
+ ! + ===================================================
+ ksig = 1
+ iv = 5
+
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, 1) = pstDYn(i, j)
+ enddo
+ enddo
+ ! + **********
+ call LBCnud_atm(dumy3D, iv, ksig)
+ ! + **********
+ do j = 1, my
+ do i = 1, mx
+ pstDYn(i, j) = dumy3D(i, j, 1)
+ enddo
+ enddo
+
+ ! +--START of:
+ ! +--Lateral Boundary Conditions for Wind, Temperature, Specific Humidity
+ ! + ("Nudging" Type / Davies, QJRMS, 1976, pp.405--418)
+ ! + =====================================================================
+
+ ! +--Radiative Lateral Boundary Conditions: Auxiliary Variables
+ ! + ==========================================================
+ kdim = mz
+
+ ! +--Lateral Boundary Conditions and Horizontal Filter
+ ! + =================================================
+ ! +--Wind x-Direction
+ ! + ----------------
+ iv = 1
+ ! +--Dummy Variable
+ ! + ~~~~~~~~~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = uairDY(i, j, k)
+ if(track_wind) then
+ uairDY_save(i, j, k) = uairDY(i, j, k)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! + **********
+ call LBCnud_atm(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIk_fu(1) > 0.0) then
+ do k = 1, mz
+ dumeps(k) = FIk_fu(k)
+ enddo
+ kdim = mz
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ ! +--Update
+ ! + ~~~~~~
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ uairDY(i, j, k) = dumy3D(i, j, k)
+ if(track_wind) then
+ delta_u(i, j, k, i_lbcnud) = delta_u(i, j, k, i_lbcnud) + &
+ (uairDY(i, j, k) - uairDY_save(i, j, k))
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! +--Wind y-Direction
+ ! + ----------------
+ iv = 2
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = vairDY(i, j, k)
+ if(track_wind) then
+ vairDY_save(i, j, k) = vairDY(i, j, k)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! + **********
+ call LBCnud_atm(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIk_fu(1) > 0.0) then
+ if(mmy <= 1) then
+ do k = 1, mz
+ dumeps(k) = FIk_su(k)
+ enddo
+ kdim = mz
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ do k = 1, mz
+ dumeps(k) = FIk_fu(k)
+ enddo
+ kdim = mz
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ vairDY(i, j, k) = dumy3D(i, j, k)
+ if(track_wind) then
+ delta_v(i, j, k, i_lbcnud) = delta_v(i, j, k, i_lbcnud) + &
+ (vairDY(i, j, k) - vairDY_save(i, j, k))
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! +--Specific Humidity
+ ! + -----------------
+ iv = 3
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ if(track_water) then
+ qvDY_save = qvDY
+ endif
+
+ ! +--Water Mass
+ ! + ~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3D, 1, 'BAK', 'FIL_Qv')
+ ! + ******
+
+ ! + **********
+ call LBCnud_atm(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIk_st(1) > 0.0) then
+ do k = 1, mz
+ ! dumeps(k) = FIslot/max(0.1,sigma(k)) ! too high filtering
+ dumeps(k) = FIslot / max(0.1, sqrt(sigma(k)))
+ enddo
+ kdim = mz
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3Q(i, j, k) = max(dumy3D(i, j, k), epsq)
+ enddo
+ enddo
+ enddo
+
+ ! +--Restore the Water Vapor total Mass
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3Q, 1, 'SET', 'FIL_Qv')
+ ! + ******
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qvDY(i, j, k) = dumy3Q(i, j, k)
+ enddo
+ enddo
+ enddo
+ if(track_water) then
+ delta_qv(:, :, :, j_lbcnud) = delta_qv(:, :, :, j_lbcnud) + (qvDY - qvDY_save)
+ endif
+#if(iso)
+ iso_label = 'DYNqqm_qv '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+
+ ! +--Potential Temperature
+ ! + ---------------------
+ iv = 4
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! + **********
+ call LBCnud_atm(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIk_st(1) > 0.0) then
+ do k = 1, mz
+ dumeps(k) = FIk_st(k)
+ enddo
+ kdim = mz
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, k) = dumy3D(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--TKE (Filtering only)
+ ! + --------------------
+
+ ! +--Lateral Boundary Conditions and Horizontal Filter (Microphysics)
+ ! + ================================================================
+
+ if(iterun == 0) then
+ FIsloQ = FIslot
+ endif
+
+ if(micphy) then
+ ! +--Filter Parameter, H2O Variables
+ ! + -------------------------------
+ do k = 1, mz
+
+ dumeps(k) = FIsloQ / max(0.1, sqrt(sigma(k)))
+ !XF
+ enddo
+ kdim = mz
+
+ ! +--Cloud Ice Crystals Number
+ ! + -------------------------
+ iv = 3
+ kdim = mz
+ ! +
+ do k = 1, mz
+ dumeps(k) = FIsloQ * 10.
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = ccniHY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Water Mass
+ ! + ~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3D, mzhyd, 'BAK', 'FIL_CN')
+ ! + ******
+
+ ! +--Nudging LBC
+ ! + ~~~~~~~~~~~~~
+ ! + **********
+ call LBCnud_000(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIsloQ > 0.0) then
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3Q(i, j, k) = max(dumy3D(i, j, k), zero)
+ enddo
+ enddo
+ enddo
+
+ ! +--Restore the Hydrometeor total Mass
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3Q, mzhyd, 'SET', 'FIL_CN')
+ ! + ******
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ccniHY(i, j, k) = dumy3Q(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Cloud Ice Crystals Concentration
+ ! + --------------------------------
+ iv = 3
+ kdim = mz
+ do k = 1, mz
+ dumeps(k) = FIsloQ * 10.
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = qiHY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Water Mass
+ ! + ~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3D, mzhyd, 'BAK', 'FIL_Qi')
+ ! + ******
+
+ ! +--Nudging LBC
+ ! + ~~~~~~~~~~~
+ ! + **********
+ call LBCnud_000(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIsloQ > 0.0) then
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3Q(i, j, k) = max(dumy3D(i, j, k), zero)
+ enddo
+ enddo
+ enddo
+
+ ! +--Restore the Hydrometeor total Mass
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3Q, mzhyd, 'SET', 'FIL_Qi')
+ ! + ******
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qiHY(i, j, k) = dumy3Q(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ iso_label = 'DYNqqm_qi '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+
+ ! +--Snow Flakes
+ ! + -----------
+ iv = 3
+ kdim = mz
+ do k = 1, mz
+ dumeps(k) = FIsloQ / max(0.1, sqrt(sigma(k)))
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = qsHY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Water Mass
+ ! + ~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3D, mzhyd, 'BAK', 'FIL_Qs')
+ ! + ******
+
+ ! +--Nudging LBC
+ ! + ~~~~~~~~~~~
+ ! + **********
+ call LBCnud_000(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIsloQ > 0.0) then
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3Q(i, j, k) = max(dumy3D(i, j, k), zero)
+ enddo
+ enddo
+ enddo
+
+ ! +--Restore the Hydrometeor total Mass
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3Q, mzhyd, 'SET', 'FIL_Qs')
+ ! + ******
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qsHY(i, j, k) = dumy3Q(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ iso_label = 'DYNqqm_qs '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+
+ ! +--Cloud Droplets
+ ! + --------------
+ iv = 3
+ kdim = mz
+ do k = 1, mz
+ dumeps(k) = FIsloQ * 10.
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = qwHY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Water Mass
+ ! + ~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3D, mzhyd, 'BAK', 'FIL_Qw')
+ ! + ******
+
+ ! +--Nudging LBC
+ ! + ~~~~~~~~~~~~~
+ ! + **********
+ call LBCnud_000(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIsloQ > 0.0) then
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3Q(i, j, k) = max(dumy3D(i, j, k), zero)
+ enddo
+ enddo
+ enddo
+
+ ! +--Restore the Hydrometeor total Mass
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3Q, mzhyd, 'SET', 'FIL_Qw')
+ ! + ******
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qwHY(i, j, k) = dumy3Q(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ iso_label = 'DYNqqm_qw '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ ! +--Rain Drops
+ ! + ----------
+ iv = 3
+ kdim = mz
+ do k = 1, mz
+ dumeps(k) = FIsloQ / max(0.1, sqrt(sigma(k)))
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = qrHY(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Water Mass
+ ! + ~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3D, mzhyd, 'BAK', 'FIL_Qr')
+ ! + ******
+
+ ! +--Nudging LBC
+ ! + ~~~~~~~~~~~~~
+ ! + **********
+ call LBCnud_000(dumy3D, iv, kdim)
+ ! + **********
+
+ ! +--Horizontal Filter
+ ! + ~~~~~~~~~~~~~~~~~
+ if(FIsloQ > 0.0) then
+ if(mmy <= 1) then
+ ! + *********
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + *********
+ else
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3Q(i, j, k) = max(dumy3D(i, j, k), zero)
+ enddo
+ enddo
+ enddo
+
+ ! +--Restore the Hydrometeor total Mass
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! + ******
+ call DYNqqm(dumy3Q, mzhyd, 'SET', 'FIL_Qr')
+ ! + ******
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ qrHY(i, j, k) = dumy3Q(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+#if(iso)
+ iso_label = 'DYNqqm_qr '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+
+ ! +--Filtering of Tracer Variables
+ ! + ==============================
+ if(ntracr > 0) then
+#if(TC)
+ do n = 1, ntrac
+ ! +--Mass
+ ! + ----
+ do k = 1, mz
+ sumv(k) = 0.0
+ dumeps(k) = FIsloQ
+ do j = 1, my
+ do i = 1, mx
+ sumv(k) = qxTC(i, j, k, n) * pstDYn(i, j) + sumv(k)
+ dumy3D(i, j, k) = qxTC(i, j, k, n)
+ enddo
+ enddo
+ enddo
+ ! +--Filtering (2D)
+ ! + --------------
+ if(mmy <= 1) then
+ ! + **************
+ call DYNfil_1D(dumy3D, dumeps, kdim)
+ ! + **************
+ else
+ ! +--Filtering (3D)
+ ! + --------------
+ if(no_vec) then
+ if(openmp) then
+ ! + **********
+ call DYNfil_3D_mp(dumy3D, dumeps, kdim)
+ ! + **********
+ else
+ ! + **********
+ call DYNfil_3D(dumy3D, dumeps, kdim)
+ ! + **********
+ endif
+ else
+ ! + **************
+ call DYNfilv3D(dumy3D, dumeps, kdim)
+ ! + **************
+ endif
+ endif
+ ! +--Restore Mass
+ ! + ------------
+ do k = 1, mz
+ sumvn = 0.0
+ do j = 1, my
+ do i = 1, mx
+ qxTC(i, j, k, n) = max(zero, dumy3D(i, j, k))
+ sumvn = qxTC(i, j, k, n) * pstDYn(i, j) + sumvn
+ enddo
+ enddo
+ if(sumvn > 0.0) then
+ sumvn = sumv(k) / sumvn
+ do j = 1, my
+ do i = 1, mx
+ qxTC(i, j, k, n) = qxTC(i, j, k, n) * sumvn
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ qxTC(i, j, k, n) = 0.0
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+#endif
+ endif
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of DIABATIC INITIALISATION +++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Global Correction for p*
+ ! + ========================
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ PHYSICS ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Radiative Processes and 1D Surface Physics
+ ! + ==========================================
+ if(physic) then
+ if(track_water) then
+ qvDY_save = qvDY
+ endif
+ ! + **********
+ call CVAgen_MNH
+ ! + **********
+ if(track_water) then
+ delta_qv(:, :, :, j_cvagen) = delta_qv(:, :, :, j_cvagen) + (qvDY - qvDY_save)
+ endif
+#if(iso)
+ iso_label = 'CVAgen_MNH'
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ if(mod(iterun, jtRadi) == 0) then
+ ! + **********
+ call PHYrad_top(DistST)
+ call PHYrad_CEP_mp(DistST)
+ ! + **********
+ ave_swd = 0
+ do i = 2, mx - 1
+ do j = 2, my - 1
+ ave_swd = ave_swd + RAdsol(i, j)
+ enddo
+ enddo
+
+ ave_swd = ave_swd / real((mx - 2) * (my - 2))
+
+ jtRadi = jtRadi2
+ if(ave_swd <= 50) jtRadi = nint(jtRadi2 * 1.5)
+ if(ave_swd <= 10) jtRadi = nint(jtRadi2 * 2.0)
+ if(ave_swd <= 1) jtRadi = nint(jtRadi2 * 3.0)
+
+ dtRadi = max(600., min(7200., dt * jtRadi))
+ jtRadi = nint(real(dtRadi) / dt)
+ !cCA #if(MR)
+ ! cCA : MR does not exist ?
+ ! end if
+ !cCA #endif
+ endif
+ if(mod(iterun, jtPhys) == 0) then
+ call PHY_SISVAT_MP(ihamr, nhamr)
+#if(iso)
+ iso_label = 'PHY_SISVAT'
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ endif
+ endif
+
+ ! +--Update of Surface Temperature
+ ! + =============================
+ do n = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ tsrfSL(i, j, n) = tsrfSL(i, j, n) + dtgSL(i, j, n)
+ enddo
+ enddo
+ enddo
+ if(reaLBC) then
+ ! + **********
+ call LBCnud_srf
+ ! + **********
+
+ endif
+
+ do j = 1, my
+ do i = 1, mx
+ TairSL(i, j) = 0.
+ enddo
+ enddo
+ do iw = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ TairSL(i, j) = TairSL(i, j) + SLsrfl(i, j, iw) * tsrfSL(i, j, iw)
+ enddo
+ enddo
+ enddo
+ do j = 1, my
+ do i = 1, mx
+ pktaDY(i, j, mzz) = TairSL(i, j) / exp(cap * log(pstDY(i, j) + ptopDY))
+ enddo
+ enddo
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+#if(GR)
+ ! 2D Gravity Current Simulation (Forcing : -10C/jour)
+ ! if (i >= imez-2.and. &
+ ! i <= imez+2 ) &
+ ! pktRAd(i,j,k) = pktRAd(i,j,k) -31.d-6*dt
+#endif
+ pktaDY(i, j, k) = pktaDY(i, j, k) + pktRAd(i, j, k)
+ enddo
+ enddo
+ enddo
+#if(AO)
+ ! +--cpl : GIVE FIELDS TO OASIS
+ ! + ==========================
+ !$OMP BARRIER
+ !$OMP MASTER
+ ! + ***********
+ call MAR_2_OASIS
+ ! + ***********
+ !$OMP END MASTER
+ !$OMP BARRIER
+#endif
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ TIME BASE ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ itexpe = itexpe + 1
+ iterun = iterun + 1
+
+ ! + ******
+ call timgeo
+ call timcur
+ ! + ******
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ OUTPUT +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--Ice-Sheet Surface Mass Balance
+ ! + ==============================
+ if(iterun <= 1) then
+ nbr_call_outice = ((3600. * 24. / OutdyIB) / (dt * 144.)) ! every 10min if 1 day
+ nbr_call_outice = max(1, min(10, nbr_call_outice))
+ do while(mod(int(real(3600. * 24. / OutdyIB) / dt) &
+ , nbr_call_outice) /= 0 .and. nbr_call_outice /= 1)
+ nbr_call_outice = nbr_call_outice - 1
+ enddo
+ endif
+ if(iterun == 1 .or. mod(iterun, nbr_call_outice) == 0) then
+ ! + ******
+ call OUTice
+ ! + ******
+ endif
+
+ ! +--Particular Output for Wind Vector
+ ! + =================================
+ iout = 0
+
+ if(mmy > 1 .and. mod(jmmMAR, 2) == 0 .and. jssMAR == 0) iout = 1
+ if(mmy == 1 .and. mod(jmmMAR, 10) == 0 .and. jssMAR == 0) iout = 1
+
+ if(iout == 1) then
+ idum = 1
+ jdum = 1
+ adum = 0.0
+ do i = ip11, mx1
+ do j = 1, my
+ if(adum < abs(uairDY(ip1(i), j, mz) - uairDY(im1(i), j, mz))) then
+ idum = i
+ jdum = j
+ adum = abs(uairDY(ip1(i), j, mz) - uairDY(im1(i), j, mz))
+ endif
+ enddo
+ enddo
+#if(NH)
+ ! +--Non-Hydrostatic Pressure Perturbation
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ pnhLav = 0.
+ pnh_av = 0.
+ do k = 1, mz
+ do j = jp11, my1
+ pnhLav = pnhLav + pairNH(ip11, j, k) * pstDYn(ip11, j) * sigma(k) &
+ + pairNH(mx1, j, k) * pstDYn(mx1, j) * sigma(k)
+ enddo
+ if(mmy > 1) then
+ do i = ip11, mx1
+ pnhLav = pnhLav + pairNH(i, jp11, k) * pstDYn(i, jp11) * sigma(k) &
+ + pairNH(i, my1, k) * pstDYn(i, my1) * sigma(k)
+ enddo
+ endif
+ do j = jp11, my1
+ do i = ip11, mx1
+ pnh_av = pnh_av + pairNH(i, j, k) * pstDYn(i, j) * sigma(k)
+ enddo
+ enddo
+ enddo
+ if(mmy == 1) then
+ pnhLav = pnhLav / (2 * mz)
+ pnh_av = pnh_av / ((mx - 2) * mz)
+ else
+ pnhLav = pnhLav / ((2 * (mx - 2) + 2 * (my - 2)) * mz)
+ pnh_av = pnh_av / ((mx - 2) * (my - 2) * mz)
+ endif
+#endif
+ ! 2-D and 3-D Simulations
+ id6 = 6
+ idum = max(idum, 7)
+ idum = min(idum, mx - 6)
+#if(GR)
+ ! idum = mx - 6
+#endif
+#if(BS)
+ if(mmy == 1) idum = imez
+#endif
+ if(mmx == 1) then
+ ! 1-D Simulations
+ id6 = 0
+ idum = 1
+ endif
+ do i = idum - id6, idum + id6
+ vecx1(i) = 10.0 * (pstDYn(i, jdum) + ptopDY)
+#if(NH)
+ vecx3(i) = 10.0 * pstDYn(i, jdum) * pairNH(i, jdum, mz)
+#endif
+#if(BS)
+ vecx4(i) = 0.0
+ do k = 1, mz
+ vecx4(i) = vecx4(i) + ssvSL(i, jdum, k) * qsHY(i, jdum, k) &
+ * pstDY(i, jdum) * dsigm1(k) &
+ * 1.0e3 * grvinv
+ enddo
+#endif
+ enddo
+ if(mmx > 1 .and. mmy == 1) then
+ do i = imez - 10, imez + 30
+ vecx2(i) = 10.0 * (pstDYn(i, 1) - pstDYn(imez - 10, 1) &
+ - pstDY1(i, 1) + pstDY1(imez - 10, 1))
+ enddo
+ endif
+ if(mmx == 1) then
+ write(21, 21) itexpe, jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhlrGE(iSND, jSND), minuGE, jsecGE, &
+ (uairDY(1, 1, k), k = mz - 9, mz), &
+ (vairDY(1, 1, k), k = mz - 9, mz)
+ 21 format(i5, i3, '-', a3, '-', i4, '/', i2, '.', i2, '.', i2, ' ||', 10f6.2, &
+ /, 24x, 'LT ||', 10f6.2)
+ else
+ if(mmy > 1) then
+
+ write(21, 22) itexpe, jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, &
+ (uairDY(i, jdum, mz), i = idum - 6, idum - 1), &
+ idum, jdum, (uairDY(i, jdum, mz), i = idum, idum + 5), &
+ ttime, itizGE(idum, jdum), &
+ (vecx1(i), i = idum - 6, idum - 1), &
+ xxkm(idum) / 1000., (vecx1(i), i = idum, idum + 5)
+
+ 22 format(i7, i3, '-', a3, '-', i4, '/', i2, '.', i2, '.', i2, ' ||', 6f7.1, &
+ ' | (', i3, ',', i3, ')', f5.1, ' |', 5f7.1, &
+ /, 3x, a8, 9x, 'UT (', i3, ') ||', 6f7.1, &
+ ' |', f6.0, 'km', f7.1, ' |', 5f7.1 &
+ )
+ else
+
+ write(21, 23) itexpe, jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE, &
+ (uairDY(i, jdum, mz), i = idum - 6, idum - 1), &
+ idum, jdum, (uairDY(i, jdum, mz), i = idum, idum + 5), &
+ ttime, itizGE(idum, jdum), &
+ (vecx1(i), i = idum - 6, idum - 1), &
+ xxkm(idum), (vecx1(i), i = idum, idum + 5)
+
+ 23 format(i7, i3, '-', a3, '-', i4, '/', i2, '.', i2, '.', i2, ' ||', 6f7.1, &
+ ' | (', i4, ',', i2, ')', f5.1, ' |', 5f7.1, &
+ /, 3x, a8, 9x, 'UT (', i3, ') ||', 6f7.1, &
+ ' |', f6.0, 'km', f7.1, ' |', 5f7.1 &
+ )
+ endif
+#if(NH)
+ write(21, 24)(vecx3(i), i = idum - 6, idum - 1), &
+ (vecx3(i), i = idum, idum + 5)
+#endif
+ 24 format(3x, 8x, 9x, ' ', 3x, ' ||', 6f7.1, &
+ ' |', 6x, ' ', f7.1, ' |', 5f7.1)
+
+ 25 format(' p_HN Averages (Domain/LB) ||', 42x, &
+ ' | [Pa] ', f7.1, ' |', f7.1)
+ endif
+ ! +
+ if(mmx > 1 .and. mmy == 1) then
+ ppp = 10 * pstDY(imez - 10, 1)
+ write(22, 221) itexpe, (uairDY(i, 1, mz), i = imez - 10, imez + 30)
+ write(23, 221) itexpe, ((tairDY(i, 1, mz) - TfSnow), i = imez - 10, imez + 30)
+ 221 format(i10, 20f5.1, /, 10x, 21f5.1)
+ write(24, 223) itexpe, (vecx2(i), i = imez - 10, imez + 30)
+ 223 format(i10, 20f5.2, /, 10x, 21f5.2)
+ endif
+ ! +
+
+ endif
+
+ ! +
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of the INTERNAL TIME INCREMENTATION (nboucl over dt) +++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +
+#if(iso)
+ iso_label = 'TIME end '
+ iso_time = iso_time + 1
+ call mariso_write_file(iso_time, iso_label)
+#endif(iso)
+ enddo
+ !cCA iboucl = iboucl + 1
+ !cCA if (iboucl <= nboucl) go to 2
+ ! +
+ ! +--Vertical Wind Speed wairDY (z Coordinate system)
+ ! + ================================================
+ ! +
+ ! cCA : stand alone surface model disactivated for simplification (GO TO)
+ ! #if(SA)
+ ! if (sALONE) go to 40
+ ! #endif
+ ! +
+ ! + ******
+ if(.not. convec .and. mmx > 1) call dynwww
+ ! + ******
+ ! +
+ ! +
+
+ !cCA 40 continue
+
+ ! +--OUTPUT for Graphs
+ ! + =================
+ !cCA iprint = iprint + 1
+ if(log_nc == 1) then
+ ! + dt_Loc is assumed
+ ! + ******
+ ipr_nc = ipr_nc + 1
+ call out_nc(ipr_nc)
+ ! + ******
+ else
+ ! + ******
+ call OUTgks
+ ! + ******
+ endif
+
+ ! +--Save of Model Variables
+ ! + =======================
+ if(safVAR .and. jdh_LB /= -1) then
+ ! + ******
+ call outsav
+ ! + ******
+ else if(jdh_LB == -1) then
+ write(6, 6600)
+ 6600 format(/, '############################################', &
+ /, '# NO LATERAL BOUNDARY CONDITIONS AVAILABLE #', &
+ /, '############################################', /, 1x)
+ stop
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end of the EXTERNAL TIME INCREMENTATION (nprint over dt * nboucl) ++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ enddo
+ !cCA if (iprint >= nprint) go to 30
+ !cCA go to 3
+ !cCA 30 continue
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ CLOSE FILES ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ close(unit = 4)
+ close(unit = 21)
+
+ if(mx > 1 .and. my <= 1) then
+ close(unit = 22)
+ close(unit = 23)
+ close(unit = 24)
+ endif
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ end OF RUN +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+#if(SB)
+ ! + ******
+ call sbcnew
+ ! + ******
+#endif
+#if(AO)
+ ! +--Coupling termination
+ ! + ====================
+ !$OMP BARRIER
+ !$OMP MASTER
+ ! + *********************
+ call oasis_terminate(info)
+ ! + *********************
+ if(info /= OASIS_Ok) then
+ WRITE(6, *) 'An error occured in '
+ WRITE(6, *) 'oasis_terminate = '
+ WRITE(6, *) info
+ endif
+ !$OMP END MASTER
+ !$OMP BARRIER
+#endif
+
+ ! +--MAR termination
+ ! + ===============
+ open(unit = 1, status = 'unknown', file = 'MAR.OK')
+ write(1, 1000) itexpe, jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE
+ write(6, 1000) itexpe, jdarGE, labmGE(mmarGE), iyrrGE, &
+ jhurGE, minuGE, jsecGE
+ 1000 format('MAR execution stopped normaly at iteration', i8, &
+ /, 'Time is', i13, '-', a3, '-', i4, &
+ '/', i2, '.', i2, '.', i2, ' UT')
+ close(unit = 1)
+
+ stop
+endprogram mar
diff --git a/MAR/code_mar/mar0sv_mod.f90 b/MAR/code_mar/mar0sv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a26332182eddbb065eb13658710a4a85670e57cd
--- /dev/null
+++ b/MAR/code_mar/mar0sv_mod.f90
@@ -0,0 +1,49 @@
+module mar0sv
+ use mardim
+ use mar_sv
+ use mardsv
+ implicit none
+ integer, save :: islpSV(-nsol:0)
+ integer, save :: isnpSV(nsno)
+ integer, save :: islmSV(-nsol:0)
+ integer, parameter :: nkhy = 50
+ real, save :: Implic, Explic
+ ! dzmiSV : dz_(i-1/2)
+ real, save :: dzmiSV(-nsol:0)
+ ! dzi_SV : dz_(i-1)/(dz_(i)+dz_(i-1))
+ real, save :: dzi_SV(-nsol:0)
+ ! dziiSV : dz_(i) /(dz_(i)+dz_(i-1))
+ real, save :: dziiSV(-nsol:0)
+ ! dtz_SV : dt / dz
+ real, save :: dtz_SV(-nsol:0)
+ ! dtz_SV2 : dt / dz
+ real, save :: dtz_SV2(-nsol:0)
+ ! dz78SV : 7/8 (dz)
+ real, save :: dz78SV(-nsol:0)
+ ! dz34SV : 3/4 (dz)
+ real, save :: dz34SV(-nsol:0)
+ ! dz_8SV : 1/8 (dz)
+ real, save :: dz_8SV(-nsol:0)
+ ! dzAvSV : 1/8dz_(-1)+3/4dz+1/8dz_(+1)
+ real, save :: dzAvSV(-nsol:0)
+ ! OcndSV : Swab Ocean / Soil Ratio
+ real, save :: OcndSV
+ ! RF__SV : Root Fraction
+ real, save :: RF__SV(0:nvgt, -nsol:0)
+ ! rocsSV : Soil Contribution to (ro c)_s
+ real, save :: rocsSV(0:nsot)
+ ! etamSV : Soil Minimum Humidity
+ real, save :: etamSV(0:nsot)
+ ! s1__SV : ... X eta**( b+2), DR97(3.36)
+ real, save :: s1__SV(0:nsot)
+ ! s2__SV : ... X eta**(2b+3), DR97(3.35)
+ real, save :: s2__SV(0:nsot)
+ ! aKdtSV : Khyd=a*eta+b: a * dt
+ real, save :: aKdtSV(0:nsot, 0:nkhy)
+ ! bKdtSV : Khyd=a*eta+b: b * dt
+ real, save :: bKdtSV(0:nsot, 0:nkhy)
+ ! aKdtSV2 : Khyd=a*eta+b: a * dt
+ real, save :: aKdtSV2(0:nsot, 0:nkhy)
+ ! bKdtSV2 : Khyd=a*eta+b: b * dt
+ real, save :: bKdtSV2(0:nsot, 0:nkhy)
+endmodule mar0sv
diff --git a/MAR/code_mar/mar_2_oasis.f90 b/MAR/code_mar/mar_2_oasis.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5ff32f3796adf5013be93617f56ed582b6119737
--- /dev/null
+++ b/MAR/code_mar/mar_2_oasis.f90
@@ -0,0 +1,227 @@
+subroutine MAR_2_OASIS
+ ! +--------------------------------------------------------------------------+
+ ! | 1-12-2019 |
+ ! | subroutine MAR_2_OASIS transfers MAR variables to OASIS |
+ ! | |
+ ! | |
+ ! | A chaque pas de tps, apres fromcpl, intocpl est appele ici; |
+ ! | si il_time_secs correspond au pas de temps precedant le couplage, |
+ ! | alors son action est effective (via prism_put), |
+ ! | et MAR envoie ses champs via givfld (oasis) |
+ ! | a NEMO au pas de temps du couplage. |
+ ! | L'appel a chaque pas de temps sert au moins au calcul de moyennes |
+ ! | (cf AVERAGE dans namcouple) |
+ ! | |
+ ! | cf mar_module.f90 |
+ ! | cf OASIS-3 user guide (december 2004) |
+ ! +--------------------------------------------------------------------------+
+ USE mod_oasis
+ USE mar_module
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_hy
+ use mar_ra
+ use mar_sl
+ use mar_ao
+ use mar_wk
+
+ implicit none
+
+ ! +--MAR Variables
+ ! + ----------------
+
+ integer i, j, k, m, n
+
+ ! +--cpl-1 Let's extract or calculate the usefull fields
+ ! + ===================================================
+
+ if(iterun == 0) then
+ write(6, *) 'Ini summed precip for OASIS'
+ write(6, *) 'MAR first time step : iterun = ', iterun
+ do i = 1, mx; do j = 1, my
+ lprecipAO_t2(i, j) = 0
+ sprecipAO_t2(i, j) = 0
+ enddo;
+ enddo
+ endif
+
+ !cleaning
+ do i = 1, mx; do j = 1, my
+ evapAO(i, j) = 0.
+ ievpAO(i, j) = 0.
+ lprecipAO(i, j) = 0.
+ sprecipAO(i, j) = 0.
+ enddo;
+ enddo
+
+ !rotation of wind on a regular grid
+ call wind_rot(UairDY(:, :, mz), VairDY(:, :, mz), uuao, vvao)
+
+ do i = 2, mx - 1
+ do j = 2, my - 1
+ lprecipAO_t1(i, j) = lprecipAO_t2(i, j) !total liq. precip since iterun=0 at dt-1
+ lprecipAO_t2(i, j) = rainHY(i, j) !total liq. precip since iterun=0 at dt
+ lprecipAO(i, j) = (lprecipAO_t2(i, j) - lprecipAO_t1(i, j)) !liquid precip between dt-1 and dt (mm.w.e)
+
+ sprecipAO_t1(i, j) = sprecipAO_t2(i, j) !total sol. precip since iterun=0 dt-1
+ sprecipAO_t2(i, j) = snowHY(i, j) + crysHY(i, j) !total sol. precip since iterun=0 (at itexpe)
+ sprecipAO(i, j) = (sprecipAO_t2(i, j) - sprecipAO_t1(i, j)) !solid precip between dt-1 and dt (mm.w.e)
+
+ !Conversion m.w.e to kg.m-2.s-1
+ lprecipAO(i, j) = lprecipAO(i, j) * 1000./dt
+ sprecipAO(i, j) = sprecipAO(i, j) * 1000./dt
+
+ ! for blowing snow ?
+ ! if (sprecipAO(i,j).ge.0.) then
+ ! upsnowAO(i,j) = 0.
+ ! else
+ ! upsnowAO(i,j) = -sprecipAO(i,j)
+ ! sprecipAO(i,j) = 0.
+ ! end if
+
+ evapAO(i, j) = -SLuqsl(i, j, 1) * rolvDY(i, j, mz) * 1.e3 !evaporation over ocean (negative, kg.m-2.s-1)
+ ievpAO(i, j) = -SLuqsl(i, j, 2) * rolvDY(i, j, mz) * 1.e3 !sublimation over sea ice (negative, kg.m-2.s-1)
+ evapAO(i, j) = evapAO(i, j) + ievpAO(i, j) !Evap total (ocean + sublimation)
+
+ !Utilise maintenant vent rot au lieu de uairDY, vairDY
+
+ do n = 1, 2
+ if(n == 1) then ! ocean
+ cpa = cp * (1 + qvswDY(i, j, mz) * cpvir)
+
+ ! downward solar (W.m-2)
+ radsolAO(i, j, n) = RAdsol(i, j) * (1.0 - albAO(i, j, n))
+ ! downward IR (net, W.m-2)
+ radirAO(i, j, n) = RAd_ir(i, j) &
+ - EmiWatao * stefan * tsrfsl(i, j, n)**4
+ ! downward sensible (W.m-2)
+ hsenAO(i, j, n) = SLutsl(i, j, n) * cpa * rolvDY(i, j, mz) * 1.e3
+ ! downward latent (W.m-2)
+ hlatAO(i, j, n) = SLuqsl(i, j, n) * rolvDY(i, j, mz) * 1.e3 * Lv_H2O
+ ! downward non solar (W.m-2)
+ radtotAO(i, j, n) = radirAO(i, j, n) &
+ + hsenAO(i, j, n) &
+ + hlatAO(i, j, n)
+
+ ! UoceAO en dehors de domaine NEMO mais dans MAR = valeur plus proche voisin
+ ! dans NEMO lors du couplage. Evite les 0 sur les bords?
+
+ normdUAO = sqrt((uuao(i, j) - UoceAO(i, j))**2 &
+ + (vvao(i, j) - VoceAO(i, j))**2)
+ ! wind stress on T grid (N.m-2)
+ TauxtAO(i, j, n) = cdmSL(i, j, n)**2 * normdUAO * rolvDY(i, j, mz) &
+ * (uuao(i, j) - UoceAO(i, j)) * 1.e3
+ TauytAO(i, j, n) = cdmSL(i, j, n)**2 * normdUAO * rolvDY(i, j, mz) &
+ * (vvao(i, j) - VoceAO(i, j)) * 1.e3
+
+ endif
+ if(n == 2) then ! sea ice
+ ! moist air heat capacity for ice
+ cpa = cp * (1 + qvsiDY(i, j, mz) * cpvir)
+
+ ! downward solar (W.m-2)
+ radsolAO(i, j, n) = RAdsol(i, j) * (1.0 - albAO(i, j, n))
+ ! downward IR (net, W.m-2)
+ radirAO(i, j, n) = RAd_ir(i, j) &
+ - Emisnoao * stefan * tsrfsl(i, j, n)**4
+ ! downward sensible (W.m-2)
+ hsenAO(i, j, n) = SLutsl(i, j, n) * cpa * rolvDY(i, j, mz) * 1.e3
+ ! downward latent (W.m-2)
+ hlatAO(i, j, n) = SLuqsl(i, j, n) * rolvDY(i, j, mz) * 1.e3 * Ls_H2O
+ ! downward non solar (W.m-2)
+ radtotAO(i, j, n) = radirAO(i, j, n) &
+ + hsenAO(i, j, n) &
+ + hlatAO(i, j, n)
+
+ ! Derivee des flux non solaire selon la temperature pour eviter les oscillations
+ ! latent flux derivative/T Clausius-Clapeyron for Dqsat/DT
+ DFlAO(i, j, n) = -rolvDY(i, j, mz) * SLuusl(i, j, n) &
+ * cdhSL(i, j, n) * R_Rv * 1.e3 &
+ * (Ls_H2O)**2 &
+ * (qvsiDY(i, j, mzz)) &
+ / (RDryAi * tsrfsl(i, j, n)**2)
+ ! sensible flux derivative/T
+ DFsAO(i, j, n) = -rolvDY(i, j, mz) * cpa * 1.e+3 &
+ * cdhSL(i, j, n) * SLuusl(i, j, n)
+ ! IR flux derivative/T
+ DFiAO(i, j, n) = -4 * epsAO * stefan * tsrfsl(i, j, n)**3
+ ! total derivative/T
+ DFtotAO(i, j, n) = DFlAO(i, j, n) + DFsAO(i, j, n) + DFiAO(i, j, n)
+
+ ! UiceAO ViceAO en dehors de domaine NEMO mais dans MAR = valeur plus proche
+ ! voisin dans NEMO lors du couplage. Evite les 0 sur les bords?
+ normdUAO = sqrt((uuao(i, j) - UiceAO(i, j))**2 &
+ + (vvao(i, j) - ViceAO(i, j))**2)
+
+ !uairday and vairday has been changed by rorated wind
+ !wind stress on T grid (N.m-2)
+ TauxtAO(i, j, n) = cdmSL(i, j, n)**2 * normdUAO * rolvDY(i, j, mz) &
+ * (uuao(i, j) - UiceAO(i, j)) * 1.e3
+ TauytAO(i, j, n) = cdmSL(i, j, n)**2 * normdUAO * rolvDY(i, j, mz) &
+ * (vvao(i, j) - ViceAO(i, j)) * 1.e3
+
+ endif
+
+ enddo
+
+ enddo
+ enddo
+
+ do n = 1, 2
+ do i = 1, mx - 1
+ do j = 1, my - 1
+ TauxuAO(i, j, n) = 0.5 * (TauxtAO(i, j, n) + TauxtAO(i + 1, j, n)) ! U grid
+ TauyuAO(i, j, n) = 0.5 * (TauytAO(i, j, n) + TauytAO(i + 1, j, n)) ! U grid
+ TauxvAO(i, j, n) = 0.5 * (TauxtAO(i, j, n) + TauxtAO(i, j + 1, n)) ! V grid
+ TauyvAO(i, j, n) = 0.5 * (TauytAO(i, j, n) + TauytAO(i, j + 1, n)) ! V grid
+ enddo
+ enddo
+ do i = 1, mx !bord des grilles
+ TauxvAO(i, my, n) = TauxtAO(i, my, n)
+ TauyvAO(i, my, n) = TauxtAO(i, my, n)
+ enddo
+ do j = 1, my
+ TauxuAO(mx, j, n) = TauxtAO(mx, j, n)
+ TauyuAO(mx, j, n) = TauxtAO(mx, j, n)
+ enddo
+ enddo
+
+ do i = 1, mx
+ do j = 1, my
+ do n = 1, 2
+ if(maskSL(i, j) /= 1) then
+ TauxuAO(i, j, n) = 0.
+ TauyuAO(i, j, n) = 0.
+ TauxvAO(i, j, n) = 0.
+ TauyvAO(i, j, n) = 0.
+ DFtotAO(i, j, n) = 0.
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! +--cpl-2 Now let's give the fields to oasis
+ ! + ========================================
+
+ il_time_secs = iterun * idt
+ ! temps en sec depuis le debut du run, au pas precedant
+ ! write(*, *) ' call intocpl, itexpe =', itexpe !for debug
+
+ call intocpl(il_time_secs, radsolAO(:, :, 2), radsolAO(:, :, 1), &
+ radtotAO(:, :, 2), radtotAO(:, :, 1), DFtotAO(:, :, 2), &
+ evapAO, lprecipAO, sprecipAO, &
+ ievpAO, &
+ TauxuAO(:, :, 1), TauxuAO(:, :, 2), &
+ TauyuAO(:, :, 1), TauyuAO(:, :, 2), &
+ TauxvAO(:, :, 1), TauxvAO(:, :, 2), &
+ TauyvAO(:, :, 1), TauyvAO(:, :, 2))
+ ! + *******
+
+ return
+endsubroutine MAR_2_OASIS
+
diff --git a/MAR/code_mar/mar_2d_mod.f90 b/MAR/code_mar/mar_2d_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6f94e7c994ad81888e14bfdc7f0d9dcf765f4cb5
--- /dev/null
+++ b/MAR/code_mar/mar_2d_mod.f90
@@ -0,0 +1,64 @@
+module mar_2d
+ use mardim
+ implicit none
+!! integer, save :: indx(klon)
+!! integer, save :: indy(klon)
+! integer, save :: jhlr2D(klon)
+! integer, save :: ioutIO(5)
+! character(len = 20) :: mphy2D(klon)
+! real, save :: pkta2D(klon, klev)
+! real, save :: tair2D(klon, klev)
+! real, save :: rolv2D(klon, klev)
+! real, save :: pst2D(klon)
+! real, save :: gpmi2D(klon, klev + 1)
+! real, save :: gplv2D(klon, klev + 1)
+! real, save :: uair2D(klon, klev)
+! real, save :: vair2D(klon, klev)
+! real, save :: qv2D(klon, klev)
+! real, save :: pk2D(klon, klev)
+! real, save :: pst2Dn(klon)
+! real, save :: wair2D(klon, klev)
+! real, save :: qg2D(klon, klev)
+! real, save :: qw2D(klon, klev)
+! real, save :: qr2D(klon, klev)
+! real, save :: qi2D(klon, klev)
+! real, save :: qs2D(klon, klev)
+! real, save :: cfra2D(klon, klev)
+! real, save :: dqi2D(klon, klev)
+! real, save :: dqw2D(klon, klev)
+! real, save :: qvsw2D(klon, klev + 1)
+! real, save :: qvsi2D(klon, klev + 1)
+! real, save :: ccni2D(klon, klev)
+! real, save :: ccnw2D(klon, klev)
+! real, save :: rain2D(klon)
+! real, save :: snow2D(klon)
+! real, save :: crys2D(klon)
+! real, save :: hlat2D(klon, klev)
+! real, save :: snf2D(klon, klev)
+! real, save :: sbl2D(klon, klev)
+! real, save :: rnf2D(klon, klev)
+! real, save :: evp2D(klon, klev)
+! real, save :: smt2D(klon, klev)
+! real, save :: ect_2D(klon, klev)
+! real, save :: TUkv2D(klon, klev)
+! real, save :: prec2D(klon)
+! real, save :: snoh2D(klon)
+! real, save :: tsrf2D(klon)
+ real, save :: W2xyz1(klon, klev)
+ real, save :: W2xyz2(klon, klev)
+ real, save :: W2xyz3(klon, klev)
+ real, save :: W2xyz4(klon, klev)
+ real, save :: W2xyz5(klon, klev + 1)
+ real, save :: W2xyz6(klon, klev + 1)
+ real, save :: W2xyz7(klon, klev + 1)
+ real, save :: W2xyz8(klon, klev + 1)
+ real, save :: W2xyz9(klon, klev)
+ real, save :: W2xyz0(klon, klev)
+! real, save :: wat01D(klon)
+! real, save :: wat11D(klon)
+! real, save :: wat21D(klon)
+! real, save :: watf1D(klon)
+! real, save :: enr01D(klon)
+! real, save :: enr11D(klon)
+! real, save :: enr21D(klon)
+endmodule mar_2d
diff --git a/MAR/code_mar/mar_allocate.f90 b/MAR/code_mar/mar_allocate.f90
new file mode 100644
index 0000000000000000000000000000000000000000..594967f9f846eae2e90f2c53b94d9b302df7f49b
--- /dev/null
+++ b/MAR/code_mar/mar_allocate.f90
@@ -0,0 +1,59 @@
+subroutine mar_allocate
+
+ ! +------------------------------------------------------------------------+
+ ! | MAR initialization 28-11-2022 MAR |
+ ! | subroutine mar_allocate is used to initialize allocatable variables |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_ra
+ use mar_sl
+ use mar_sv
+ use mar_tv
+ use mar_hy
+ use mar_ca
+ use marssn
+ use mar_ib
+ use marsib
+ use mar_wk
+ use mar_io
+ use mardsv
+ use mar_te
+ use mar_ao
+ use mar0sv
+ use mar_tu
+ use radcep
+ use mar_lb
+ use marvec
+ use mar_ao
+ use mar_ub
+ use mar_bs
+
+ implicit none
+
+ call mar_ao_init()
+ call mar_bs_init()
+ call mar_ca_init()
+ call mar_dy_init()
+ call mar_hy_init()
+ call mar_ib_init()
+ call mar_lb_init()
+ call mar_ra_init()
+ call mar_sl_init()
+ call marssn_init()
+ call mar_te_init()
+ call mar_tu_init()
+ call mar_tv_init()
+ call mar_ub_init()
+ call marvec_init()
+ call mar_wk_init()
+ call radcep_init()
+
+ return
+
+endsubroutine
diff --git a/MAR/code_mar/mar_ao_mod.f90 b/MAR/code_mar/mar_ao_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a5c8595d0ee042ee2549a137fa55279325f10ecf
--- /dev/null
+++ b/MAR/code_mar/mar_ao_mod.f90
@@ -0,0 +1,174 @@
+! mar_ao : atmosphere-ocean (MAR-NEMO) coupling
+! =============================================
+! Sea Ice/Snow albedo for SISVAT albAOsisv is defined in MARySV.inc
+module mar_ao
+ use mardim
+ implicit none
+ ! fields given by ocean/ice model
+ ! ===============================
+ ! sicsAO: sea ice fraction (from 0 to 1)
+ real(kind=8), save, allocatable :: sicsAO(:, :)
+ ! hicAO : sea ice thickness
+ real(kind=8), save, allocatable :: hicAO(:, :)
+ ! hsnoAO : snow thickness over sea ice
+ real(kind=8), save, allocatable :: hsnoAO(:, :)
+ ! albAO : weighted albedo on sea-ice (2) or on open-water (1)
+ real(kind=8), save, allocatable :: albAO(:, :, :)
+ ! UoceAO : surface ocean velocity along X-axis
+ real(kind=8), save, allocatable :: UoceAO(:, :)
+ ! VoceAO : surface ocean velocity along Y-axis
+ real(kind=8), save, allocatable :: VoceAO(:, :)
+ ! UiceAO : surface ice velocity along X-axis
+ real(kind=8), save, allocatable :: UiceAO(:, :)
+ ! ViceAO : surface ice velocity along Y-axis
+ real(kind=8), save, allocatable :: ViceAO(:, :)
+ ! srftAO : surf. temperature (K)
+ real(kind=8), save, allocatable :: srftAO(:, :, :)
+ integer, save :: aoss
+ integer, save :: aogla
+ integer, save :: aoalb
+ integer, save :: aotic
+ integer, save :: aohic
+ integer, save :: aohsn
+ integer, save :: ao_uo
+ integer, save :: ao_vo
+ ! if gt 0 then MAR has receveid the field => update of the value
+ integer, save :: ao_ui
+ integer, save :: ao_vi
+ ! fields used to feat the ocean/ice model
+ ! =======================================
+ ! hlatAO : downard latent turbulent heat flux (W.m-2)
+ real(kind=8), save, allocatable :: hlatAO(:, :, :)
+ ! hsenAO : downard sensible turbulent heat flux (W.m-2)
+ real(kind=8), save, allocatable :: hsenAO(:, :, :)
+ ! radsolAO : downard solar heat flux (W.m-2)
+ real(kind=8), save, allocatable :: radsolAO(:, :, :)
+ ! radirAO : downard infrared heat flux (W.m-2)
+ real(kind=8), save, allocatable :: radirAO(:, :, :)
+ ! radtotAO : downard total non solar heat flux (W.m-2)
+ real(kind=8), save, allocatable :: radtotAO(:, :, :)
+ ! DFlAO : latent flux derivative /temperature (W.m-2.K-1)
+ real(kind=8), save, allocatable :: DFlAO(:, :, :)
+ ! DFsAO : sensible flux derivative /temperature (W.m-2.K-1)
+ real(kind=8), save, allocatable :: DFsAO(:, :, :)
+ ! DFiAO : infrared flux derivative /temperature (W.m-2.K-1)
+ real(kind=8), save, allocatable :: DFiAO(:, :, :)
+ ! DFtotAO : total non solar heat flux derivative /temperature (W.m-2.K-1)
+ real(kind=8), save, allocatable :: DFtotAO(:, :, :)
+ real(kind=8), save :: normdUAO
+ real(kind=8), save, allocatable :: ievpAO(:, :)
+ ! lp_accuAO,sp_accuAO,lprecipAO_t1,lprecipAO_t2,sprecipAO_t1,sprecipAO_t2
+ ! (usefull to express lprecip and sprecip in kg.m-2.s-1)
+ real(kind=8), save, allocatable :: lp_accuAO(:, :)
+ real(kind=8), save, allocatable :: sp_accuAO(:, :)
+ ! evapAO : evaporation on ice or water (kg.m-2.s-1)
+ real(kind=8), save, allocatable :: evapAO(:, :)
+ ! lprecipAO : liquid precipitation (kg.m-2.s-1)
+ real(kind=8), save, allocatable :: lprecipAO(:, :)
+ real(kind=8), save, allocatable :: lprecipAO_t1(:, :)
+ real(kind=8), save, allocatable :: lprecipAO_t2(:, :)
+ ! sprecipAO : solid precipitation (kg.m-2.s-1)
+ real(kind=8), save, allocatable :: sprecipAO(:, :)
+ real(kind=8), save, allocatable :: sprecipAO_t1(:, :)
+ real(kind=8), save, allocatable :: sprecipAO_t2(:, :)
+ ! upsnowAO : surface upward snow flux where sea ice (kg.m-2.s-1)
+ ! UsrfAO : surface wind following the X-axis (m.s-1)
+ real(kind=8), save, allocatable :: UsrfAO(:, :)
+ ! VsrfAO : surface wind following the Y-axis (m.s-1)
+ real(kind=8), save, allocatable :: VsrfAO(:, :)
+ ! TauxuAO : weighted surface downward X-axis stress on U-grid (Pa)
+ real(kind=8), save, allocatable :: TauxuAO(:, :, :)
+ ! TauyuAO : weighted surface downward Y-axis stress on U-grid (Pa)
+ real(kind=8), save, allocatable :: TauyuAO(:, :, :)
+ ! TauxvAO : weighted surface downward X-axis stress on V-grid (Pa)
+ real(kind=8), save, allocatable :: TauxvAO(:, :, :)
+ ! TauyvAO : weighted surface downward Y-axis stress on V-grid (Pa)
+ real(kind=8), save, allocatable :: TauyvAO(:, :, :)
+ ! TauxtAO : weighted surface downward X-axis stress on T-grid (Pa)
+ real(kind=8), save, allocatable :: TauxtAO(:, :, :)
+ ! TauytAO : weighted surface downward Y-axis stress on T-grid (Pa)
+ real(kind=8), save, allocatable :: TauytAO(:, :, :)
+ ! usefull fields for coupling
+ ! ===========================
+ ! il_time_secs : time counter for coupling
+ integer, save :: il_time_secs
+ ! jtCpl : frequency of coupling (in time steps)
+ integer, save :: jtCpl
+ ! iH2O : time counter usefull for precip calculation
+ integer, save :: iH2O
+ integer, save :: info
+ integer, save :: il_time_exp0
+ integer, save :: tocken_AO
+ ! t_Cpl : time between 2 intocpl call (s)
+ real, save :: t_Cpl
+ ! epsAO : emissivity
+ real, save :: epsAO
+ ! cpv : water vapor specific heat (J/kg/K)
+ real, save :: cpv
+ ! cpa : air specific heat (wet air) (J/kg/K)
+ real, save :: cpa
+ ! cpvir : [cpv/cp - 1] (usefull value for qsat) (-)
+ real, save :: cpvir
+ ! R_Rv : [gas cste dry air=287.0] / [gas cste moist air=461.5]
+ real, save :: R_Rv
+ ! uuao: uair_dy (u component of the wind) on a regular grid
+ real, save :: uuao(mx, my)
+ ! vvao: vair_dy (v component of the wind) on a regular grid
+ real, save :: vvao(mx, my)
+ logical coupling_ao
+ real, save :: weightao(mx, my)
+ real, save :: weightao_sst(mx, my)
+ real, save :: weightao_sic(mx, my)
+ real, save :: weightao_st(mx, my)
+ real, save :: weightao_al(mx, my)
+ real, save :: weightao_sit(mx, my)
+ real, save :: weightao_snt(mx, my)
+ character(len=300) fileao
+
+contains
+
+ subroutine mar_ao_init()
+
+ use mardim, only: mx, my, mw
+ implicit none
+
+ allocate(sicsAO(mx, my))
+ allocate(hicAO(mx, my))
+ allocate(hsnoAO(mx, my))
+ allocate(albAO(mx, my, mw))
+ allocate(UoceAO(mx, my))
+ allocate(VoceAO(mx, my))
+ allocate(UiceAO(mx, my))
+ allocate(ViceAO(mx, my))
+ allocate(srftAO(mx, my, mw))
+ allocate(hlatAO(mx, my, mw))
+ allocate(hsenAO(mx, my, mw))
+ allocate(radsolAO(mx, my, mw))
+ allocate(radirAO(mx, my, mw))
+ allocate(radtotAO(mx, my, mw))
+ allocate(DFlAO(mx, my, mw))
+ allocate(DFsAO(mx, my, mw))
+ allocate(DFiAO(mx, my, mw))
+ allocate(DFtotAO(mx, my, mw))
+ allocate(ievpAO(mx, my))
+ allocate(lp_accuAO(mx, my))
+ allocate(sp_accuAO(mx, my))
+ allocate(evapAO(mx, my))
+ allocate(lprecipAO(mx, my))
+ allocate(lprecipAO_t1(mx, my))
+ allocate(lprecipAO_t2(mx, my))
+ allocate(sprecipAO(mx, my))
+ allocate(sprecipAO_t1(mx, my))
+ allocate(sprecipAO_t2(mx, my))
+ allocate(UsrfAO(mx, my))
+ allocate(VsrfAO(mx, my))
+ allocate(TauxuAO(mx, my, mw))
+ allocate(TauyuAO(mx, my, mw))
+ allocate(TauxvAO(mx, my, mw))
+ allocate(TauyvAO(mx, my, mw))
+ allocate(TauxtAO(mx, my, mw))
+ allocate(TauytAO(mx, my, mw))
+
+ endsubroutine mar_ao_init
+
+endmodule mar_ao
diff --git a/MAR/code_mar/mar_bs_mod.f90 b/MAR/code_mar/mar_bs_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..579d93a39bdc449a2bcc55aa8c01aafc771d8bb8
--- /dev/null
+++ b/MAR/code_mar/mar_bs_mod.f90
@@ -0,0 +1,40 @@
+! mar_bs : mar blowing snow
+! =========================
+module mar_bs
+ use mardim
+ implicit none
+ integer, parameter :: nn_pro = 30
+ ! BS_pro : Normalized Blowing Snow Profile (Suspension Layer)
+ real, save :: BS_pro(nn_pro)
+ ! z0SaBS : Z0 due to Sastrugi Height [m]
+ real, save, allocatable :: z0SaBS(:, :, :)
+ ! z0emBS : Z0 due to Snow Erosion [m]
+ real, save, allocatable :: z0emBS(:, :, :)
+ ! hSalBS : Height above the Surface (Top of Saltation Layer) [m]
+ real, save :: hSalBS(mx, my)
+ ! u_stBS : Time Ave. Frict. Vel. for Blowing Snow Surface Turbulent Flux [m/s]
+ real, save :: u_stBS(mx, my)
+ ! wSalBS : Blowing Snow Sedimentation (Top of Saltation Layer) [m/s]
+ real, save :: wSalBS(mx, my)
+ real, save :: FracBS
+ real, save :: ua_0BS(mx, my)
+ real, save :: va_0BS(mx, my)
+ real, save :: VVs_BS(mx, my)
+ real, save :: DDs_BS(mx, my)
+ real, save :: RRs_BS(mx, my)
+
+
+contains
+
+ subroutine mar_bs_init()
+
+ use mardim, only: mx, my,mw
+ implicit none
+
+ allocate(z0SaBS(mx, my, mw))
+ allocate(z0emBS(mx, my, mw))
+
+ endsubroutine mar_bs_init
+
+
+endmodule mar_bs
diff --git a/MAR/code_mar/mar_ca_mod.f90 b/MAR/code_mar/mar_ca_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..679a73aa7ef70b2a07d84e89e681aa8a2e178787
--- /dev/null
+++ b/MAR/code_mar/mar_ca_mod.f90
@@ -0,0 +1,37 @@
+! mar_ca : convective adjustment scheme
+! =====================================
+module mar_ca
+ use mardim
+ implicit none
+ ! Time interval (transformed in number of iterations)
+ ! between two checks of convective unstability
+ integer, save :: adj_CA(mx, my)
+ integer, save :: int_CA
+ ! Characteristic Time Scale for Convection
+ real, save :: capeCA(mx, my)
+ real, save, allocatable :: dpktCA(:, :, :)
+ real, save, allocatable :: dqv_CA(:, :, :)
+ real, save, allocatable :: dqw_CA(:, :, :)
+ real, save, allocatable :: dqi_CA(:, :, :)
+ real, save :: drr_CA(mx, my)
+ real, save :: dss_CA(mx, my)
+ real, save :: dsn_CA(mx, my)
+ real, save :: rainCA(mx, my)
+ real, save :: snowCA(mx, my)
+ real, save :: tau_CA(mx, my)
+
+contains
+
+ subroutine mar_ca_init()
+
+ use mardim, only: mx, my, mz
+ implicit none
+
+ allocate(dpktCA(mx, my, mz))
+ allocate(dqv_CA(mx, my, mz))
+ allocate(dqw_CA(mx, my, mz))
+ allocate(dqi_CA(mx, my, mz))
+
+ endsubroutine mar_ca_init
+
+endmodule mar_ca
diff --git a/MAR/code_mar/mar_cu_mod.f90 b/MAR/code_mar/mar_cu_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1f6129cc6c42b94519ed38bcc5e3f83dbee9155f
--- /dev/null
+++ b/MAR/code_mar/mar_cu_mod.f90
@@ -0,0 +1,16 @@
+! mar_cu : cubic spline interpolation
+! ===================================
+module mar_cu
+ use mardim
+ implicit none
+ ! Xh and Xb are cubic spline auxiliary variables
+ ! used for HORIZONTAL advection (blank->x,w->y)
+ real, save :: CUspxh(mx)
+ real, save :: CUspxb(mx)
+ real, save :: CUspyh(my)
+ real, save :: CUspyb(my)
+ ! Xh and Xb are cubic spline auxiliary variables
+ ! used for VERTICAL advection (routine cubver)
+ real, save :: CUspzh(mz)
+ real, save :: CUspzb(mz)
+endmodule mar_cu
diff --git a/MAR/code_mar/mar_dy_mod.f90 b/MAR/code_mar/mar_dy_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5fc6588e2fbaeb78bbc3fa3f62956e0625e744a5
--- /dev/null
+++ b/MAR/code_mar/mar_dy_mod.f90
@@ -0,0 +1,105 @@
+! mar_dy: mar dynamical variables
+! ===============================
+module mar_dy
+ use mardim
+ implicit none
+ logical, save :: openmp
+ ! iyrDYN: Year
+ integer, save :: iyrDYN
+ ! mmaDYN: Month
+ integer, save :: mmaDYN
+ ! jdaDYN: Day
+ integer, save :: jdaDYN
+ ! jhuDYN: Hour (UT)
+ integer, save :: jhuDYN
+ ! uairDY : x-wind speed component (m/s)
+ real, save :: uairDY(mx, my, mz)
+ ! vairDY : y-wind speed component (m/s)
+ real, save :: vairDY(mx, my, mz)
+ ! pktaDY : potential temperature divided by 100.[kPa]**(R/Cp)
+ real, save :: pktaDY(mx, my, mzz)
+ ! tairDY : real temperature (K)
+ real, save :: tairDY(mx, my, mz)
+ ! pkDY : Exner Potential = p[kPa]**(R/Cp)
+ real, save, allocatable :: pkDY(:, :, :)
+ ! qvsiDY : Saturation Specific Humidity over Ice (kg/kg)
+ real, save, allocatable :: qvsiDY(:, :, :)
+ ! qvDY : Specific Humidity (kg/kg)
+ real, save :: qvDY(mx, my, mz)
+ ! qvswDY : Saturation Specific Humidity over Water (kg/kg)
+ real, save, allocatable :: qvswDY(:, :, :)
+ ! pstDY1 : Model Pressure Depth at INITIAL Time Step (kPa)
+ real, save :: pstDY1(mx, my)
+ ! opstDY : Model Pressure Depth at previous Time Step (kPa)
+ real, save :: opstDY(mx, my)
+ ! pstDY : Model Pressure Depth at current Time Step (kPa)
+ real, save :: pstDY(mx, my)
+ ! pstDYn: Model Pressure Depth at next Time Step (kPa)
+ real, save :: pstDYn(mx, my)
+ ! pstDY2: Model Pressure Depth (current) (squared) (kPa2)
+ real, save :: pstDY2(mx, my)
+ ! ptopDY: Pressure at Model Top (kPa)
+ real, save :: ptopDY
+ ! fcorDY: Coriolis Parameter (s-1)
+ real, save :: fcorDY(mx, my)
+ ! SFm_DY: Map Scale Factor (-)
+ real, save :: SFm_DY(mx, my)
+ ! rolvDY: air specific mass index (i,j,k) at (i,j,k) (Ton/m3)
+ real, save :: rolvDY(mx, my, mz)
+ ! romiDY: air specific mass index (i,j,k) at (i,j,k+1/2) (Ton/m3)
+ real, save, allocatable :: romiDY(:, :, :)
+ ! virDY: air loading by water (vapor, liquid and solid)
+ real, save :: virDY(mx, my, mz)
+ ! ubefDY: uairDY at Previous Time Step (in the Leap-Frog)
+ real, save, allocatable :: ubefDY(:, :, :)
+ ! vbefDY: vairDY at Previous Time Step (in the Leap-Frog)
+ real, save, allocatable :: vbefDY(:, :, :)
+ ! dgzXDY is the geopotential gradient just before current time step
+ ! X=(x->x direction, y->y direction)
+ real, save, allocatable :: dgzxDY(:, :, :)
+ real, save, allocatable :: dgzyDY(:, :, :)
+ ! dg1XDY is the geopotential gradient just before previous time step
+ ! X=(x->x direction, y->y direction)
+ real, save, allocatable :: dg1xDY(:, :, :)
+ real, save, allocatable :: dg1yDY(:, :, :)
+ ! wairDY : Vertical Wind Speed (in z coordinate) (cm/s)
+ real, save :: wairDY(mx, my, mz)
+ ! psigDY : p* X Vertical Wind Speed (in sigma coordinate)
+ real, save :: psigDY(mx, my, mz)
+ ! wsigDY : Vertical Wind Speed (in sigma coordinate)
+ real, save :: wsigDY(mx, my, mz)
+ ! CFLzDY : Vertical CFL (in sigma coordinate)
+ real, save :: CFLzDY
+ ! gplvDY: Geopotential of sigma Levels (= g z)
+ real, save :: gplvDY(mx, my, mzz)
+ ! gpmiDY: Geopotential between sigma Levels (i,j,k)->layer(i,j,k-1/2)
+ real, save :: gpmiDY(mx, my, mzz)
+ ! ugeoDY: x-geostrophic wind speed (assumed external) (m/s)
+ real, save, allocatable :: ugeoDY(:, :, :)
+ ! vgeoDY: y-geostrophic wind speed (assumed external) (m/s)
+ real, save, allocatable :: vgeoDY(:, :, :)
+
+contains
+
+ subroutine mar_dy_init()
+
+ use mardim, only: mx, my, mz,mzz
+ implicit none
+
+ allocate( pkDY(mx, my, mz))
+ allocate(qvsiDY(mx, my, mzz))
+ allocate(qvswDY(mx, my, mzz))
+ allocate(romiDY(mx, my, mz))
+ allocate(ubefDY(mx, my, mz))
+ allocate(vbefDY(mx, my, mz))
+ allocate(dgzxDY(mx, my, mz))
+ allocate(dgzyDY(mx, my, mz))
+ allocate(ugeoDY(mx, my, mz))
+ allocate(vgeoDY(mx, my, mz))
+ allocate(dg1xDY(mx, my, mz))
+ allocate(dg1yDY(mx, my, mz))
+
+ endsubroutine mar_dy_init
+
+endmodule mar_dy
+
diff --git a/MAR/code_mar/mar_ew_mod.f90 b/MAR/code_mar/mar_ew_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..765f0733936463b3f8f94e94a3390c45739a0502
--- /dev/null
+++ b/MAR/code_mar/mar_ew_mod.f90
@@ -0,0 +1,18 @@
+! Energy and Water Balance Variables
+module mar_ew
+ use mardim
+ implicit none
+ ! wat*EW: Total Precipitable Water in the Air Column [m]
+ real, save :: wat0EW(mx, my)
+ real, save :: wat1EW(mx, my)
+ real, save :: wat2EW(mx, my)
+ ! watfEW: Water Flux (Atm. --> Srf.) during 1 Time Step [m]
+ real, save :: watfEW(mx, my)
+ ! enr*EW: Total Energy (Sens. +Lat.) in the Air Column [m]
+ real, save :: enr0EW(mx, my)
+ real, save :: enr1EW(mx, my)
+ real, save :: enr2EW(mx, my)
+ ! labels
+ character(len=20), save :: mphyEW(mx, my)
+ character(len=20), save :: mauxEW
+endmodule mar_ew
diff --git a/MAR/code_mar/mar_fi_mod.f90 b/MAR/code_mar/mar_fi_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..68bab8b521c25a4afa8801ea56002098dd7e0b14
--- /dev/null
+++ b/MAR/code_mar/mar_fi_mod.f90
@@ -0,0 +1,30 @@
+! mar_fi : mar filter parameters
+! ==============================
+module mar_fi
+ use mardim
+ implicit none
+ ! FIsloq : Implicit Filter Parameter (Slow mPHYS)
+ real, save :: FIsloq
+ ! FIslot, FIk_st(mz) : Implicit Filter Parameter (Slow Dyn./Temperature)
+ real, save :: FIslot
+ real, save :: FIk_st(mz)
+ ! FIslou, FIk_su(mz) : Implicit Filter Parameter (Slow Dyn./Wind Speed)
+ real, save :: FIslou
+ real, save :: FIk_su(mz)
+ ! FIfstu, FIk_fu(mz) : Implicit Filter Parameter (Fast Dyn./Wind Speed)
+ real, save :: FIfstu
+ real, save :: FIk_fu(mz)
+ real, save :: FIfstt
+ real, save :: FIk_ft(mz)
+ ! FIslop : Implicit Filter Parameter (Slow Dyn./Pressure)
+ real, save :: FIslop
+ ! FIfstp, FIk_fp(mz): Implicit Filter Parameter (Fast Dyn./Pressure)
+ real, save :: FIfstp
+ real, save :: FIk_fp(mz)
+ ! FIkhmn : Horizontal Diffusion Coefficient
+ ! equivalent to the Filter Effect on Long Waves
+ real, save :: FIkhmn
+ ! FIspon : Implicit Filter Parameter (Top Absorber)
+ real, save :: FIspon(mzabso)
+ logical, parameter :: FIBord = .true.
+endmodule mar_fi
diff --git a/MAR/code_mar/mar_ge_mod.f90 b/MAR/code_mar/mar_ge_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..966db66ba6ec6bf8406b53560d70808bc3b2432a
--- /dev/null
+++ b/MAR/code_mar/mar_ge_mod.f90
@@ -0,0 +1,127 @@
+module mar_ge
+
+ use mardim
+
+ implicit none
+
+ ! labmGE : Month Label
+ character(len=3), parameter :: labmGE(0:12) = (/'---', 'Jan', 'Feb', &
+ 'Mar', 'Apr', 'May', 'Jun', 'Jul', &
+ 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/)
+ ! iyr0GE : Initial Year
+ integer, save :: iyr0GE
+ ! iyrrGE : Current Year
+ integer, save :: iyrrGE
+ ! mma0GE : Initial Month
+ integer, save :: mma0GE
+ ! mmarGE : Current Month
+ integer, save :: mmarGE
+ ! jda0GE : Initial Day
+ integer, save :: jda0GE
+ ! jdarGE : Current Day
+ integer, save :: jdarGE
+ ! jhu0GE : Initial Hour (UT)
+ integer, save :: jhu0GE
+ ! jhurGE : Current Hour (UT)
+ integer, save :: jhurGE
+ ! jhl0GE : Initial Hour (LT)
+ integer, save :: jhl0GE
+ ! jhlrGE : Current Hour (LT)
+ integer, save :: jhlrGE(mx, my)
+ ! minuGE : Minute
+ integer, save :: minuGE
+ ! jsecGE : second
+ integer, save :: jsecGE
+ ! ksecGE : Cent.of second
+ integer, save :: ksecGE
+ ! itizGE : Time Zone (numero du fuseau horaire)
+ integer, save :: itizGE(mx, my)
+ ! njyrGE : Number of Days since Begin of the Year before Current Month
+ integer, save :: njyrGE(0:12)
+ ! njybGE : Leap Year Correction to current Day of the Year
+ integer, save :: njybGE(0:12)
+ ! njmoGE : Number of Days in each Month of the Year
+ integer, save :: njmoGE(0:12)
+ ! njmbGE : Leap Year Correction to each Month of the Year
+ integer, save :: njmbGE(0:12)
+ ! nhyrGE : Number of Hours in one Year
+ integer, save :: nhyrGE
+ ! GElat0 : Latitude (Degrees)
+ real, save :: GElat0
+ ! GElon0 : Longitude (Degrees)
+ real, save :: GElon0
+ ! GElatr : Latitude (Radians)
+ real, save :: GElatr(mx, my)
+ ! GElonh : Longitude (Hours)
+ real, save :: GElonh(mx, my)
+ ! GEtrue : On Oblique Stereographic Projection:
+ ! Relative CoLatitude where distances (Degrees)
+ ! on Proj.plane = distances on sphere
+ real, save :: GEtrue
+ ! GEddxx : Direction x-axis (Degrees)
+ real, save :: GEddxx
+ ! slatGE : Sine of Latitude
+ real, save :: slatGE(mx, my)
+ ! clatGE : Cosine of Latitude
+ real, save :: clatGE(mx, my)
+ real, save :: deglon2D(mx, my)
+ real, save :: deglat2D(mx, my)
+ integer, parameter :: n_azim = 8
+ ! czenGE : Cosine of Solar Zenith Angle
+ real, save :: czenGE(mx, my)
+ ! cz0_GE : Cosine of Solar Zenith Angle (Minimum Value for solari call)
+ real, save :: cz0_GE
+ ! omenGE : Azimuth of Fall Line (Radians)
+ real, save :: omenGE(mx, my)
+ ! slopGE : Cosine of Fall Line Angle
+ real, save :: slopGE(mx, my)
+ ! cmntGE : Cosine of Solar Zenith Angle
+ ! (Minimum Value from Mountains Mask / All Directions)
+ real, save :: cmntGE(mx, my, n_azim)
+ ! daziGE : Unit Angle for Mountains Mask (Radians)
+ real, save :: daziGE
+ ! czmnGE : Cosine of Solar Zenith Angle (Minimum Value from Mountains Mask)
+ real, save :: czmnGE(mx, my)
+ ! cverGE : Cosine of Solar Normal Angle
+ real, save :: cverGE(mx, my)
+ ! rsunGE : Insolation (Top of the Atmosphere) (W/m2)
+ real, save :: rsunGE
+ ! tlsrGE : Sun Rise Local Time / (iSND,jSND) (hour)
+ real, save :: tlsrGE
+ ! tlssGE : Sun Set Local Time / (iSND,jSND) (hour)
+ real, save :: tlssGE
+ ! tl__GE : Current Local Time / (iSND,jSND) (hour)
+ real, save :: tl__GE
+
+contains
+
+ integer(kind=8) function ou2sGE(yr, mo, da, hh, mm, ss)
+ ! +----------------------------------------------------------------+
+ ! | MAR INPUT 31-11-2012-XF MAR |
+ ! +----------------------------------------------------------------+
+
+ implicit none
+
+ integer, intent(in) :: yr
+ integer, intent(in) :: mo
+ integer, intent(in) :: da
+ integer, intent(in) :: hh
+ integer, intent(in) :: mm
+ integer, intent(in) :: ss
+ integer :: y
+
+ ou2sGE = 0
+ do y = iyr0GE, yr - 1
+ ou2sGE = ou2sGE + 365 + njmbGE(2) * max(0, 1 - mod(y, 4))
+ enddo
+
+ ou2sGE = ou2sGE + njyrGE(mo) + &
+ njybGE(mo) * max(0, 1 - mod(yr, 4)) + da - 1
+
+ ou2sGE = ou2sGE * 24 + hh
+ ou2sGE = ou2sGE * 3600 + mm * 60 + ss
+
+ return
+ endfunction ou2sGE
+
+endmodule mar_ge
diff --git a/MAR/code_mar/mar_hy_mod.f90 b/MAR/code_mar/mar_hy_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3d91886f16bfc1eaab3362739132a182dc74360f
--- /dev/null
+++ b/MAR/code_mar/mar_hy_mod.f90
@@ -0,0 +1,125 @@
+! mar_hy : mar microphysics (hydrometeors)
+! ========================================
+module mar_hy
+ use mardim
+ implicit none
+ ! turnHY: set = T when rhcrHY is reached => microphysics turned on
+ logical, save :: turnHY
+ ! cminHY : cloud fraction (minimum)
+ real, save :: cminHY
+ ! rhcrHY: critical relative humidity value for condensation
+ real, save :: rhcrHY
+ ! tim_HY: time at which microphysics are taken into account
+ real, save :: tim_HY
+ ! cfraHY : cloud fraction
+ real, save, allocatable :: cfraHY(:, :, :)
+ ! ccnwHY : cloud dropplets number concentration (Nb/m3)
+ real, save, allocatable :: ccnwHY(:, :, :)
+ ! ccniHY : cloud ice crystals number concentration (Nb/m3)
+ real, save, allocatable :: ccniHY(:, :, :)
+ ! qwHY : cloud dropplets concentration (kg/kg)
+ real, save, allocatable :: qwHY(:, :, :)
+ ! qiHY : cloud ice crystals concentration (kg/kg)
+ real, save, allocatable :: qiHY(:, :, :)
+ ! qrHY : rain concentration (kg/kg)
+ real, save, allocatable :: qrHY(:, :, :)
+ ! qsHY : snow flakes concentration (kg/kg)
+ real, save, allocatable :: qsHY(:, :, :)
+ ! qgHY : graupels concentration (kg/kg)
+ ! (translucent snow pellets encased in a thin layer of ice)
+ real, save, allocatable :: qgHY(:, :, :)
+ ! snfHY : qsHY to snowfall in the atmosphere [m w.e.]
+ real, save, allocatable :: snfHY(:, :, :)
+ ! sblHY : snowfall sublimation in the atmosphere [m w.e.]
+ real, save, allocatable :: sblHY(:, :, :)
+ ! rnfHY : qrHY to rainfall in the atmosphere [m w.e.]
+ real, save, allocatable :: rnfHY(:, :, :)
+ ! evpHY : rainfall evaporation in the atmosphere [m w.e.]
+ real, save, allocatable :: evpHY(:, :, :)
+ real, save, allocatable :: smtHY(:, :, :)
+ ! depHY : snowfall condensation in the atmosphere [m w.e.]
+ real, save, allocatable :: depHY(:, :, :)
+ ! qssblHY : snow sublimated mass in the atmosphere (kg/kg)
+ real, save, allocatable :: qssblHY(:, :, :)
+ ! rainHY : integrated precipited rain
+ real, save :: rainHY(mx, my)
+ ! rai0HY : integrated precipited rain (previous time step)
+ real, save, allocatable :: rai0HY(:, :)
+ ! snowHY : integrated precipited/eroded snow
+ real, save :: snowHY(mx, my)
+ ! sno0HY : integrated precipited/eroded snow (previous time step)
+ real, save, allocatable :: sno0HY(:, :)
+ real, save, allocatable :: crysHY(:, :)
+ ! sfa0HY : integrated precipited snow (previous time step)
+ real, save, allocatable :: sfa0HY(:, :)
+ ! qsrfHY : Blowing Snow Concentration (0.325 m above the surface)
+ real, save, allocatable :: qsrfHY(:, :)
+ ! uss_HY : Blowing Snow Turbulent Flux (0.325 m above the surface)
+ real, save, allocatable :: uss_HY(:, :)
+ real, save, allocatable :: qbs_HY(:, :)
+ ! hlatHY : latent heat release [K/s] &
+ ! BLOWN * SUBLIMATION [m w.e.] (for k=1)
+ real, save, allocatable :: hlatHY(:, :, :)
+ ! dqiHY : Sublimation(-) / Deposition(+) [m w.e.]
+ real, save, allocatable :: dqiHY(:, :, :)
+ ! dqwHY : Vaporisation(-) / Condensation(+) [m w.e.]
+ real, save, allocatable :: dqwHY(:, :, :)
+ ! Hcd_HY : latent heat release [mm w.e.]
+ real, save, allocatable :: Hcd_HY(:, :)
+ ! Tcd_HY : latent heat release weighted Air Temperature [K]
+ real, save, allocatable :: Tcd_HY(:, :)
+ real, save, allocatable :: zcd_HY(:, :)
+ ! Hsb_HY : latent heat absorb. [mm w.e.]
+ real, save, allocatable :: Hsb_HY(:, :)
+ ! Tsb_HY : latent heat absorb. weighted Air Temperature [K]
+ real, save, allocatable :: Tsb_HY(:, :)
+ real, save, allocatable :: zsb_HY(:, :)
+ ! hsubHY : latent heat release [K/s] &
+ ! BLOWN * SUBLIMATION [kg/kg] per vertical level
+ real, save, allocatable :: hsubHY(:, :, :)
+ integer, save :: icntHY
+
+contains
+
+ subroutine mar_hy_init()
+
+ use mardim, only: mx, my, mz
+ implicit none
+
+ allocate(cfraHY(mx, my, mz))
+ allocate(ccnwHY(mx, my, mz))
+ allocate(ccniHY(mx, my, mz))
+ allocate(qwHY(mx, my, mz))
+ allocate(qiHY(mx, my, mz))
+ allocate(qrHY(mx, my, mz))
+ allocate(qsHY(mx, my, mzz))
+ allocate(qgHY(mx, my, mz))
+ allocate(snfHY(mx, my, mz))
+ allocate(sblHY(mx, my, mz))
+ allocate(rnfHY(mx, my, mz))
+ allocate(evpHY(mx, my, mz))
+ allocate(smtHY(mx, my, mz))
+ allocate(depHY(mx, my, mz))
+ allocate(qssblHY(mx, my, mz))
+ allocate(rai0HY(mx, my))
+ allocate(sno0HY(mx, my))
+ allocate(crysHY(mx, my))
+ allocate(sfa0HY(mx, my))
+ allocate(qsrfHY(mx, my))
+ allocate(uss_HY(mx, my))
+ allocate(qbs_HY(mx, my))
+ allocate(hlatHY(mx, my, mz))
+ allocate(dqiHY(mx, my, mz))
+ allocate(dqwHY(mx, my, mz))
+ allocate(Hcd_HY(mx, my))
+ allocate(Tcd_HY(mx, my))
+ allocate(zcd_HY(mx, my))
+ allocate(Hsb_HY(mx, my))
+ allocate(Tsb_HY(mx, my))
+ allocate(zsb_HY(mx, my))
+ allocate(hsubHY(mx, my, mz))
+
+ endsubroutine mar_hy_init
+
+
+endmodule mar_hy
diff --git a/MAR/code_mar/mar_ib_mod.f90 b/MAR/code_mar/mar_ib_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..285afe38f1e16c3e0b54a99ac9fb7165e23ab741
--- /dev/null
+++ b/MAR/code_mar/mar_ib_mod.f90
@@ -0,0 +1,797 @@
+! mar_ib : mar integrated outputs
+! ===============================
+module mar_ib
+ use mardim
+ use marssn
+ implicit none
+ integer, save :: nbr_call_outice
+ integer, save :: itrdIB
+ ! OutdyIB : Number of Outputs by Day
+ integer, parameter :: OutdyIB = 1
+ ! ml : Number of *sigma* levels for atm. var.
+ integer, parameter :: ml = 3
+ ! mlhh : Number of outputs by Day for the X-hourly output: 8 => every 3h, 24 => every hour
+ integer, parameter :: mlhh = 8
+ ! mlb : Number of sigma *surface* levels for atm. var. (boundary layer)
+ integer, parameter :: mlb = min(3, ml)
+ ! mp : Number of *pressure* levels for atm. var.
+ integer, parameter :: mp = 7
+ ! OutPLevIB : Pressure levels (in hPa)
+ real, parameter :: OutPLevIB(mp) = (/925., 850., 800., 700., 600., 500., 200./)
+ ! mztq : Number of *height* levels for temperature and humidity
+ integer, parameter :: mztq = 5
+ ! OutZTQLevIB : Height levels (in m above surface)
+ real, parameter :: OutZTQLevIB(mztq) = (/2., 10., 50., 80., 100./)
+ ! mzuv : Number of *height* levels for wind
+ integer, parameter :: mzuv = 4
+ ! OutZUVLevIB : Height levels (in m above surface)
+ real, parameter :: OutZUVLevIB(mzuv) = (/10., 50., 80., 100./)
+ ! mi : Nbr snow height levels. Initial value: mi = 12
+ integer, parameter :: mi = 18
+ ! OutshIB : Snow height levels (in m)
+ real, parameter :: OutshIB(mi) = (/0.00, 0.05, 0.10, 0.20, 0.30, 0.40, 0.50, &
+ 0.65, 0.80, 1.00, 1.50, 2.00, 3.00, 5.00, 7.5, 10.0, 15.0, 20.0/)
+ ! real, parameter :: OutshIB(mi) = (/0.0,0.1,0.2,0.4,0.6,0.8,1.0,2.0,3.0,5.0,10.,15./)
+ ! Vertical axis
+ ! -------------
+ ! dsigmaIB : sigma layer thickness
+ real, save :: dsigmaIB(ml)
+ ! Surface Mass Balance
+ ! --------------------
+ ! SIm_IB : Current Snow/Ice Mass (mmWE)
+ real, save, allocatable :: SIm_IB(:, :, :)
+ ! S_m_IB : Current Snow Mass (mmWE)
+ real, save, allocatable :: S_m_IB(:, :, :)
+ ! SIh_IB : Current Snow/Ice Height (m)
+ real, save, allocatable :: SIh_IB(:, :, :)
+ ! S_h_IB : Current Snow Height (m)
+ real, save, allocatable :: S_h_IB(:, :, :)
+ ! SSh_IB : Current Non-Superimposed H (m)
+ real, save, allocatable :: SSh_IB(:, :, :)
+ ! wet_IB : Total (mmWE)
+ real, save, allocatable :: wet_IB(:, :, :), wet0IB(:, :, :)
+ ! wee_IB : water flux (mmWE)
+ real, save, allocatable :: wee_IB(:, :, :, :), wee0IB(:, :, :, :)
+ ! wem_IB : Melting (mmWE)
+ real, save, allocatable :: wem_IB(:, :, :), wem0IB(:, :, :)
+ ! wer_IB : Refreezing (mmWE)
+ real, save, allocatable :: wer_IB(:, :, :), wer0IB(:, :, :)
+ ! weu_IB : Run-off (mmWE)
+ real, save, allocatable :: weu_IB(:, :, :), weu0IB(:, :, :)
+ ! weo_IB : Run-off (mmWE)
+ real, save, allocatable :: weo_IB(:, :, :, :), weo0IB(:, :, :, :)
+ ! wec0IB, wel0IB : Canopy/soil water
+ real, save, allocatable :: wec0IB(:, :, :), wel0IB(:, :, :)
+ ! snf_IB : Atmospheric snowfall (mmWE)
+ real, save, allocatable :: snf_IB(:, :, :), snf0IB(:, :, :)
+ ! sbl_IB : Atmospheric sublimation (mmWE)
+ real, save, allocatable :: sbl_IB(:, :, :), sbl0IB(:, :, :)
+ ! qssbl_IB : Atmospheric sublimation ratio (kg/kg)
+ real, save, allocatable :: qssbl_IB(:, :, :), qssbl0IB(:, :, :)
+ ! dep_IB : Atmospheric condensation (mmWE)
+ real, save, allocatable :: dep_IB(:, :, :), dep0IB(:, :, :)
+ ! rnf_IB : Atmospheric rainfall (mmWE)
+ real, save, allocatable :: rnf_IB(:, :, :), rnf0IB(:, :, :)
+ ! evp_IB : Atmospheric evaporation (mmWE)
+ real, save, allocatable :: evp_IB(:, :, :), evp0IB(:, :, :)
+ ! werr0IB : Rain (mmWE)
+ real, save, allocatable :: werr0IB(:, :)
+ ! wesf0IB : Snow (mmWE)
+ real, save, allocatable :: wesf0IB(:, :)
+ ! wecp0IB : Convective precip (mmWE)
+ real, save, allocatable :: wecp0IB(:, :)
+ ! wero0IB : RunOff (mmWE)
+ real, save, allocatable :: wero0IB(:, :)
+ ! wecr0IB : Ice crystals (mmWE)
+ real, save, allocatable :: wecr0IB(:, :)
+ ! wesw0IB : Surface Water (mmWE)
+ real, save, allocatable :: wesw0IB(:, :, :)
+ ! wei0IB : Bottom Ice Added (mmWE)
+ real, save, allocatable :: wei0IB(:, :, :)
+ ! weacIB : #BS accu.
+ real, save, allocatable :: weacIB(:, :, :), weac0IB(:, :, :)
+ ! weerIB : #BS erosion
+ real, save, allocatable :: weerIB(:, :, :), weer0IB(:, :, :)
+ ! Atmospheric Variables averaged
+ ! ------------------------------
+ ! mintIB : Min. Temp. (C)
+ real, save, allocatable :: mintIB(:, :, :)
+ ! maxtIB : Max. Temp. (C)
+ real, save, allocatable :: maxtIB(:, :, :)
+ ! maxwIB : Max. wind. speed (m/s)
+ real, save, allocatable :: maxwIB(:, :, :)
+ ! ttIB : Temperature (C)
+ real, save, allocatable :: ttIB(:, :, :)
+ ! tdIB : Dew Temperature (C)
+ real, save, allocatable :: tdIB(:, :, :)
+ ! uuIB : x-Wind Speed component (m/s)
+ real, save, allocatable :: uuIB(:, :, :)
+ ! vvIB : y-Wind Speed component (m/s)
+ real, save, allocatable :: vvIB(:, :, :)
+ ! uvIB : Horizontal Wind Speed (m/s)
+ real, save, allocatable :: uvIB(:, :, :)
+ ! wwIB : w-Wind Speed component (cm/s)
+ real, save, allocatable :: wwIB(:, :, :)
+ ! psigIB : SP x w-Wind Speed (SP Ds/Dt) (kPa/s)
+ real, save, allocatable :: psigIB(:, :, :)
+ ! wsigIB : w-Wind Speed Dsigma / Dt (1/s)
+ real, save, allocatable :: wsigIB(:, :, :)
+ ! ruuIB : x-Wind Speed component on regular grid (m/s)
+ real, save, allocatable :: ruuIB(:, :, :)
+ ! rotuuIB : instantaneous rotated wind on a regular grid (m/s)
+ real, save, allocatable :: rotuuIB(:, :, :)
+ ! rotvvIB : instantaneous rotated wind on a regular grid (m/s)
+ real, save, allocatable :: rotvvIB(:, :, :)
+ ! rvvIB : y-Wind Speed component on regular grid (m/s)
+ real, save, allocatable :: rvvIB(:, :, :)
+ ! ruvIB : Horizontal Wind Speed on regular grid (m/s)
+ real, save, allocatable :: ruvIB(:, :, :)
+ ! qqIB : Specific Humidity (g/kg)
+ real, save, allocatable :: qqIB(:, :, :)
+ ! rolvIB : Air specific mass (kg/m3)
+ real, save, allocatable :: rolvIB(:, :, :)
+ ! rhIB : Specific Humidity (%)
+ real, save, allocatable :: rhIB(:, :, :)
+ ! zzIB : Model Levels Height (m)
+ real, save, allocatable :: zzIB(:, :, :)
+ ! smt_IB : Integrated snow mass transport (kg/m)
+ real, save, allocatable :: smt_IB(:, :, :)
+ real, save, allocatable :: smt0IB(:, :, :)
+ ! pddIB : PDD quantity (C)
+ real, save, allocatable :: pddIB(:, :)
+ ! spIB : Surface Pressure (hPa)
+ real, save, allocatable :: spIB(:, :)
+ ! slpIB : Sea Surface Pressure (hPa)
+ real, save, allocatable :: slpIB(:, :)
+ ! ccIB : Cloud cover (-)
+ real, save, allocatable :: ccIB(:, :)
+ ! cuIB : Cloud cover Up (-)
+ real, save, allocatable :: cuIB(:, :)
+ ! cmIB : Cloud cover Middle (-)
+ real, save, allocatable :: cmIB(:, :)
+ ! cdIB : Cloud cover Low (-)
+ real, save, allocatable :: cdIB(:, :)
+ ! codIB : Cloud Optical Depth (-)
+ real, save, allocatable :: codIB(:, :)
+ ! qwIB : Cl Dropplets Concent. (kg/kg)
+ real, save, allocatable :: qwIB(:, :)
+ ! qiIB : Cl Ice Crystals Concent.(kg/kg)
+ real, save, allocatable :: qiIB(:, :)
+ ! qsIB : Snow Flakes Concent. (kg/kg)
+ real, save, allocatable :: qsIB(:, :)
+ ! qrIB : Rain Concentration (kg/kg)
+ real, save, allocatable :: qrIB(:, :)
+ ! water path: old computation [cCA 02/08/2022]
+ ! ===========================================
+ ! wvpIB : Water Vapour Path (kg/m2) / Old computation [cCA 02/08/2022]
+ real, save, allocatable :: wvpIB(:, :)
+ ! cwpIB : Condensed Water Path (kg/m2) / Old computation [cCA 02/08/2022]
+ real, save, allocatable :: cwpIB(:, :)
+ ! iwpIB : Ice Water Path (kg/m2) / Old computation [cCA 02/08/2022]
+ real, save, allocatable :: iwpIB(:, :)
+ ! water path: standard computation [cCA 02/08/2022]
+ ! =================================================
+ ! rhodzIB : air density x delta_z
+ ! rhodz : rho dz = dp / g = dsigma * SP / g (kg m-2)
+ ! rhodz : for staggered grid (usual MAR setting), dsigma = dsigm1
+ real, save, allocatable :: rhodzIB(:, :, :)
+ ! cloud_liquid_total_content tccl
+ ! cloud_ice_total_content tcci
+ ! precipitation_liquid_total_content tcpl
+ ! precipitation_ice_total_content tcpi
+ ! tcwvIB : total content water vapor = Integrated Water Vapor (IWV) or Precipitable Water (prw) (kg/m2) / Standard computation [cCA 02/08/2022]
+ real, save, allocatable :: tcwvIB(:, :)
+ ! tclcIB : total content of liquid cloud (kg/m2) cloud_liquid_total_content / Standard computation [cCA 02/08/2022]
+ real, save, allocatable :: tclcIB(:, :)
+ ! tcicIB : total content of ice cloud (kg/m2) cloud_ice_total_content / Standard computation [cCA 02/08/2022]
+ real, save, allocatable :: tcicIB(:, :)
+ ! tclpIB : total content of liquid precipitation (kg/m2) precipitation_liquid_total_content / Standard computation [cCA 02/08/2022]
+ real, save, allocatable :: tclpIB(:, :)
+ ! tcipIB : total content of ice precipitation (kg/m2) precipitation_ice_total_content / Standard computation [cCA 02/08/2022]
+ real, save, allocatable :: tcipIB(:, :)
+ ! =================================================
+ ! iwfe : eastward vertically integrated water vapor flux (water vapor * zonal wind)
+ ! iwfn : northward vertically integrated water vapor flux (water vapor * meridional wind)
+ ! ihfe : eastward vertically integrated heat flux (temperature * zonal wind)
+ ! ihfn : northward vertically integrated heat flux (temperature * meridional wind)
+ ! pblIB : height of the Primary and Secondary Seeing Layer (m)
+ real, save, allocatable :: pblIB(:, :, :)
+ ! lqsIB : Snow Part. Concent. per vertical level (kg/kg)
+ real, save, allocatable :: lqsIB(:, :, :)
+ ! lqiIB : Ice Part. Concent. per vertical level (kg/kg)
+ real, save, allocatable :: lqiIB(:, :, :)
+ ! lqrIB : Rain Part. Concent. per vertical level (kg/kg)
+ real, save, allocatable :: lqrIB(:, :, :)
+ ! lqwIB : Water Part. Concent. per vertical level (kg/kg)
+ real, save, allocatable :: lqwIB(:, :, :)
+ ! qsbIB : Sublimation of Snow Part. per vertical level (kg/kg)
+ real, save, allocatable :: qsbIB(:, :, :)
+ ! lsbIB : Vert. Integrated Sublimation of Qs (m w.e.)
+ real, save, allocatable :: lsbIB(:, :, :)
+ ! tkeIB : TKE (m2/s2)
+ real, save, allocatable :: tkeIB(:, :, :)
+ ! qbrIB : Snow ratio between kb level (~100m) and 0
+ real, save, allocatable :: qbrIB(:, :)
+ ! swn3DIB : Net SW Rad. per vertical level (W/m2)
+ real, save, allocatable :: swn3DIB(:, :, :)
+ ! lwn3DIB : Net LW Rad. per vertical level (W/m2)
+ real, save, allocatable :: lwn3DIB(:, :, :)
+ ! swnc3DIB : Clear-sky Net SW Rad. per vertical level (W/m2)
+ real, save, allocatable :: swnc3DIB(:, :, :)
+ ! lwnc3DIB : Clear-sky Net LW Rad. per vertical level (W/m2)
+ real, save, allocatable :: lwnc3DIB(:, :, :)
+ ! cod3DIB : Could Optical Depth per vertical level (-)
+ real, save, allocatable :: cod3DIB(:, :, :)
+ ! cc3DIB : Could Cover per vertical level (-)
+ real, save, allocatable :: cc3DIB(:, :, :)
+ ! Atmospheric Variables on surface levels (boundary layer)
+ ! -----------------------------------------------
+ ! ttbIB : Temperature (C)---------
+ real, save, allocatable :: ttbIB(:, :, :)
+ ! txbIB : Temperature (C)
+ real, save, allocatable :: txbIB(:, :, :)
+ ! tnbIB : Temperature (C)
+ real, save, allocatable :: tnbIB(:, :, :)
+ ! qqbIB : Specific Humidity (g/kg)
+ real, save, allocatable :: qqbIB(:, :, :)
+ ! uubIB : x-Wind Speed component (m/s)
+ real, save, allocatable :: uubIB(:, :, :)
+ ! vvbIB : y-Wind Speed component (m/s)
+ real, save, allocatable :: vvbIB(:, :, :)
+ ! uvbIB : Horizontal Wind Speed (m/s)
+ real, save, allocatable :: uvbIB(:, :, :)
+ ! zzbIB : Model Levels Height (m)
+ real, save, allocatable :: zzbIB(:, :, :)
+ ! timehIB : Time
+ real, save :: timehIB(mlhh)
+ ! tnh : Minimum temperature (C)
+ real, save, allocatable :: tnh(:, :, :)
+ ! txh : Maximum temperature (C)
+ real, save, allocatable :: txh(:, :, :)
+ ! tdh : Dewpoint temperature (C)
+ real, save, allocatable :: tdh(:, :, :)
+ ! uuh : X-Wind speed component (m/s)
+ real, save, allocatable :: uuh(:, :, :)
+ ! vvh : Y-Wind speed component (m/s)
+ real, save, allocatable :: vvh(:, :, :)
+ ! slth : Soil temperature (C)
+ real, save, allocatable :: slth(:, :, :)
+ ! slqch : Total soil moisture content (g/kg)
+ real, save, allocatable :: slqch(:, :, :)
+ ! wvph : Water vapor path (kg/m�)
+ real, save, allocatable :: wvph(:, :, :)
+ ! cphIB : Convective precipitation (mmWE)
+ real, save, allocatable :: cphIB(:, :, :)
+ ! cph0IB : Convective precipitation (mmWE)
+ real, save, allocatable :: cph0IB(:, :)
+ ! wehIB : Evapotranspiration (mmWE)
+ real, save, allocatable :: wehIB(:, :, :)
+ ! weh0IB : Evapotranspiration (mmWE)
+ real, save, allocatable :: weh0IB(:, :, :)
+ ! ztdh : Zenithal Tropospheric Delay (m)
+ real, save, allocatable :: ztdh(:, :, :)
+ ! zhdh : Zenithal Hydrostatic Delay (m)
+ real, save, allocatable :: zhdh(:, :, :)
+ ! zwdh : Zenithal Wet Delay (m)
+ real, save, allocatable :: zwdh(:, :, :)
+ ! tmh : Weighted Mean Temperature (C)
+ real, save, allocatable :: tmh(:, :, :)
+ ! capeh : Convective Av. Pot. Energy (J/kg)
+ real, save, allocatable :: capeh(:, :, :)
+ ! ssth : Sea Surface Temperature ( )
+ real, save, allocatable :: ssth(:, :, :)
+ ! sphIB : Surface pressure (hPa)
+ real, save, allocatable :: sphIB(:, :, :)
+ ! sthIB : Surface temperature (C)
+ real, save, allocatable :: sthIB(:, :, :)
+ ! tthIB : Temperature (C)
+ real, save, allocatable :: tthIB(:, :, :)
+ ! txhIB : Temperature (C)
+ real, save, allocatable :: txhIB(:, :, :)
+ ! txhIB0 : Temperature (C)
+ real, save, allocatable :: txhIB0(:, :)
+ ! tnhIB : Temperature (C)
+ real, save, allocatable :: tnhIB(:, :, :)
+ ! tnhIB0 : Temperature (C)
+ real, save, allocatable :: tnhIB0(:, :)
+ ! qqhIB : Specific Humidity (g/kg)
+ real, save, allocatable :: qqhIB(:, :, :)
+ ! uuhIB : x-Wind Speed component (m/s)
+ real, save, allocatable :: uuhIB(:, :, :)
+ ! vvhIB : y-Wind Speed component (m/s)
+ real, save, allocatable :: vvhIB(:, :, :)
+ ! swdhIB : Shortwave inc. Rad. (W/m2)
+ real, save, allocatable :: swdhIB(:, :, :)
+ ! lwdhIB : Longwave inc. Rad. (W/m2)
+ real, save, allocatable :: lwdhIB(:, :, :)
+ ! lwuhIB : Longwave out. Rad. (W/m2)
+ real, save, allocatable :: lwuhIB(:, :, :)
+ ! shfhIB : Sensible Heat (W/m2)
+ real, save, allocatable :: shfhIB(:, :, :)
+ ! lhfhIB : Latent Heat (W/m2)
+ real, save, allocatable :: lhfhIB(:, :, :)
+ ! alhIB : Albedo (temporal mean) (-)
+ real, save, allocatable :: alhIB(:, :, :)
+ ! prhIB : Precipitation (mmWE)
+ real, save, allocatable :: prhIB(:, :, :)
+ ! rfhIB : Rainfall (mmWE)
+ real, save, allocatable :: rfhIB(:, :, :)
+ ! prh0IB : Precipitation (mmWE)
+ real, save, allocatable :: prh0IB(:, :)
+ ! snfhIB : Snowfall (mmWE)
+ real, save, allocatable :: snfhIB(:, :, :)
+ ! snfh0IB : Snowfall (mmWE)
+ real, save, allocatable :: snfh0IB(:, :)
+ ! clhIB : Cloud Fraction (-)
+ real, save, allocatable :: clhIB(:, :, :)
+ ! mehIB : Surface Melt (mmWE)
+ real, save, allocatable :: mehIB(:, :, :)
+ ! meh0IB : Surface Melt (mmWE)
+ real, save, allocatable :: meh0IB(:, :)
+ ! suhIB : Sublimation (mmWE)
+ real, save, allocatable :: suhIB(:, :, :)
+ ! suh0IB : Sublimation (mmWE)
+ real, save, allocatable :: suh0IB(:, :)
+ ! ruhIB : Run-off (mmWE)
+ real, save, allocatable :: ruhIB(:, :, :)
+ ! ruh0IB : Run-off (mmWE)
+ real, save, allocatable :: ruh0IB(:, :)
+ ! smbhIB : SMB (mmWE)
+ real, save, allocatable :: smbhIB(:, :, :)
+ ! smbh0IB : SMB (mmWE)
+ real, save, allocatable :: smbh0IB(:, :)
+ ! swhIB : Surface water (mmWE)
+ real, save, allocatable :: swhIB(:, :, :)
+ ! swh0IB : Surface water (mmWE)
+ real, save, allocatable :: swh0IB(:, :)
+ ! lwc1mhIB : Total Liquid Water Content to 1m (kg/m2)
+ real, save, allocatable :: lwc1mhIB(:, :, :)
+ ! lwc2mhIB : Total Liquid Water Content to 2m (kg/m2)
+ real, save, allocatable :: lwc2mhIB(:, :, :)
+ ! t5hIB : Temperature at 50m (C)
+ real, save, allocatable :: t5hIB(:, :, :)
+ ! u5hIB : Wind at 50m (m/s)
+ real, save, allocatable :: u5hIB(:, :, :)
+ ! v5hIB : Wind at 50m (m/s)
+ real, save, allocatable :: v5hIB(:, :, :)
+ ! q5hIB : Specific Humidity at 50m (g/kg)
+ real, save, allocatable :: q5hIB(:, :, :)
+ ! p5hIB : Pressure at 50m (hPa)
+ real, save, allocatable :: p5hIB(:, :, :)
+ ! Atmospheric Variables averaged on pressure levels
+ ! -------------------------------------------------
+ ! nbpIB : Count number of valid data on pressure levels
+ real, save, allocatable :: nbpIB(:, :, :)
+ ! ttpIB : Temperature on pressure levels (C)
+ real, save, allocatable :: ttpIB(:, :, :)
+ ! qqpIB : Specific Humidity on pressure levels (g/kg)
+ real, save, allocatable :: qqpIB(:, :, :)
+ ! zzpIB : Model Levels Height on pressure levels (m)
+ real, save, allocatable :: zzpIB(:, :, :)
+ ! uupIB : x-Wind Speed component on pressure levels (m/s)
+ real, save, allocatable :: uupIB(:, :, :)
+ ! vvpIB : y-Wind Speed component on pressure levels (m/s)
+ real, save, allocatable :: vvpIB(:, :, :)
+ ! wwpIB : w-Wind Speed component on pressure levels (m/s)
+ real, save, allocatable :: wwpIB(:, :, :)
+ ! uvpIB : Horizontal Wind Speed on pressure levels (m/s)
+ real, save, allocatable :: uvpIB(:, :, :)
+ ! tairDYp : temperature on pressure levels (K)
+ real, allocatable :: tairDYp(:, :, :)
+ ! gplvDYp : Geopotential on pressure levels (= g z)
+ real, allocatable :: gplvDYp(:, :, :)
+ ! qvDYp : Specific Humidity on pressure levels (kg/kg)
+ real, allocatable :: qvDYp(:, :, :)
+ ! uairDYp : x-Wind Speed component on pressure levels (m/s)
+ real, allocatable :: uairDYp(:, :, :)
+ ! vairDYp : y-Wind Speed component on pressure levels (m/s)
+ real, allocatable :: vairDYp(:, :, :)
+ ! wairDYp : w-Wind Speed component on pressure levels (m/s)
+ real, allocatable :: wairDYp(:, :, :)
+ ! Atmospheric Variables averaged on height levels
+ ! -----------------------------------------------
+ ! ttzIB : Temperature on height levels (C)
+ real, save, allocatable :: ttzIB(:, :, :)
+ ! qqzIB : Specific Humidity on height levels (g/kg)
+ real, save, allocatable :: qqzIB(:, :, :)
+ real, save, allocatable :: rhzIB(:, :, :)
+ ! uuzIB : x-Wind Speed component on height levels (m/s)
+ real, save, allocatable :: uuzIB(:, :, :)
+ ! vvzIB : y-Wind Speed component on height levels (m/s)
+ real, save, allocatable :: vvzIB(:, :, :)
+ ! uvzIB : Horizontal Wind Speed on height levels (m/s)
+ real, save, allocatable :: uvzIB(:, :, :)
+ ! u2zIB : x-Wind Speed component on height levels (m/s)
+ real, save, allocatable :: u2zIB(:, :, :)
+ ! v2zIB : y-Wind Speed component on height levels (m/s)
+ real, save, allocatable :: v2zIB(:, :, :)
+ ! rozIB : Air density on height levels (Ton/m3)
+ real, save, allocatable :: rozIB(:, :, :)
+ ! ttzIB_0 : Temperature on height levels (C)
+ real, allocatable :: ttzIB_0(:, :, :)
+ ! qqzIB_0 : Specific Humidity on height levels (g/kg)
+ real, allocatable :: qqzIB_0(:, :, :)
+ real, allocatable :: rhzIB_0(:, :, :)
+ ! uuzIB_0 : x-Wind Speed component on height levels (m/s)
+ real, allocatable :: uuzIB_0(:, :, :)
+ ! vvzIB_0 : y-Wind Speed component on height levels (m/s)
+ real, allocatable :: vvzIB_0(:, :, :)
+ ! uvzIB_0 : Horizontal Wind Speed on height levels (m/s)
+ real, allocatable :: uvzIB_0(:, :, :)
+ ! u2zIB_0 : x-Wind Speed component on height levels (m/s)
+ real, allocatable :: u2zIB_0(:, :, :)
+ ! v2zIB_0 : y-Wind Speed component on height levels (m/s)
+ real, allocatable :: v2zIB_0(:, :, :)
+ ! ppzIB_0 : Pressure on height levels (m/s)
+ real, allocatable :: ppzIB_0(:, :, :)
+ ! rozIB_0 : Air density on height levels (Ton/m3)
+ real, allocatable :: rozIB_0(:, :, :)
+ ! Surface Variables averaged
+ ! --------------------------
+ ! swdIB : Shortwave inc. Rad. (W/m2)
+ real, save, allocatable :: swdIB(:, :)
+ ! swuIB : Shortwave out. Rad. (W/m2)
+ real, save, allocatable :: swuIB(:, :)
+ ! lwdIB : Longwave inc. Rad. (W/m2)
+ real, save, allocatable :: lwdIB(:, :)
+ ! lwuIB : Longwave out. Rad. (W/m2)
+ real, save, allocatable :: lwuIB(:, :)
+ ! sunIB : Sunshine (SWD>120) (s)
+ real, save, allocatable :: sunIB(:, :)
+ ! swdtIB : TOA Shortwave inc. Rad. (W/m2)
+ real, save, allocatable :: swdtIB(:, :)
+ ! swutIB : TOA Shortwave out. Rad. (W/m2)
+ real, save, allocatable :: swutIB(:, :)
+ ! lwutIB : TOA Longwave out. Rad. (W/m2)
+ real, save, allocatable :: lwutIB(:, :)
+ ! shfIB : Sensible Heat (W/m2)
+ real, save, allocatable :: shfIB(:, :)
+ ! lhfIB : Latent Heat (W/m2)
+ real, save, allocatable :: lhfIB(:, :)
+ ! alIB : Albedo (temporal mean) (-)
+ real, save, allocatable :: alIB(:, :)
+ ! al1IB : Albedo (SW out/SW in) (-)
+ real, save, allocatable :: al1IB(:, :, :)
+ ! al2IB : Albedo (temporal mean) (-)
+ real, save, allocatable :: al2IB(:, :, :)
+ ! frvIB : ifraTV (temporal mean) (-)
+ real, save, allocatable :: frvIB(:, :, :)
+ ! stIB : Surface Temperature (C)
+ real, save, allocatable :: stIB(:, :)
+ ! st2IB : Surface Temperature (C)
+ real, save, allocatable :: st2IB(:, :, :)
+ ! z0IB : Roughness length for Moment.(m)
+ real, save, allocatable :: z0IB(:, :, :)
+ ! r0IB : Roughness length for Heat (m)
+ real, save, allocatable :: r0IB(:, :, :)
+ ! uusIB : Friction Velocity (m/s)
+ real, save, allocatable :: uusIB(:, :, :)
+ ! utsIB : Sfc Pot. Tp. Turb. Flux (K.m/s)
+ real, save, allocatable :: utsIB(:, :, :)
+ ! uqsIB : Water Vapor Flux (kg/kg.m/s)
+ real, save, allocatable :: uqsIB(:, :, :)
+ ! ussIB : Blowing Snow Flux (kg/kg.m/s)
+ real, save, allocatable :: ussIB(:, :, :)
+ ! uusthIB : Threshold friction velocity (m/s)
+ real, save, allocatable :: uusthIB(:, :, :)
+ ! sltIB : Soil Temperature (C)
+ real, save, allocatable :: sltIB(:, :, :, :)
+ ! slqIB : Soil Humidity Content (g/kg)
+ real, save, allocatable :: slqIB(:, :, :, :)
+ ! slqcIB : Total Soil Humidity Content (g/kg)
+ real, save, allocatable :: slqcIB(:, :, :)
+ ! slqmIB : Max Soil Humidity Content (g/kg)
+ real, save, allocatable :: slqmIB(:, :, :)
+ ! sicIB : SIC (-)
+ real, save, allocatable :: sicIB(:, :)
+ real, save, allocatable :: alb1IB(:, :)
+ real, save, allocatable :: as1_IB(:, :)
+ real, save, allocatable :: alb2IB(:, :)
+ real, save, allocatable :: as2_IB(:, :)
+ real, save, allocatable :: alb3IB(:, :)
+ real, save, allocatable :: as3_IB(:, :)
+ ! *CL*
+ real, save, allocatable :: gradTIB(:, :)
+ real, save, allocatable :: maxgrTIB(:, :)
+ real, save, allocatable :: mingrTIB(:, :)
+ real, save, allocatable :: gradQIB(:, :)
+ real, save, allocatable :: maxgrQIB(:, :)
+ real, save, allocatable :: mingrQIB(:, :)
+ real, save, allocatable :: tt_intIB(:, :, :)
+ real, save, allocatable :: qq_intIB(:, :, :)
+ ! Snow pack Variables averaged
+ ! ----------------------------
+ real, save, allocatable :: agIB(:, :, :, :) ! ag (-)
+ real, save, allocatable :: g1IB(:, :, :, :) ! g1 (-)
+ real, save, allocatable :: g2IB(:, :, :, :) ! g2 (-)
+ real, save, allocatable :: roIB(:, :, :, :) ! Density (kg/m3)
+ real, save, allocatable :: tiIB(:, :, :, :) ! Temperature (C)
+ real, save, allocatable :: waIB(:, :, :, :) ! Water Content (%)
+ real, save, allocatable :: zn0IB(:, :, :), zn1IB(:, :, :) ! Snow Height (m)
+ real, save, allocatable :: zn2IB(:, :, :), zn3IB(:, :, :)
+ real, save, allocatable :: zn4IB(:, :, :), zn5IB(:, :, :)
+ real, save, allocatable :: zn6IB(:, :, :)
+ ! mb0IB : Mass Balance (mmWE)
+ real, save, allocatable :: mb0IB(:, :, :), mbIB(:, :, :)
+
+ ! Variables averaged from OASIS
+ ! -----------------------------
+ real, save, allocatable :: st2aoIB(:, :, :)
+ real, save, allocatable :: sicaoIB(:, :)
+ real, save, allocatable :: albaoIB(:, :, :)
+ real, save, allocatable :: sitaoIB(:, :)
+ real, save, allocatable :: sntaoIB(:, :)
+
+contains
+
+ subroutine mar_ib_init()
+
+ use mardim, only: mx, my, mz, mzz
+ implicit none
+
+ integer i,j,k,m
+
+ allocate(SIm_IB(mx, my, nsx))
+ allocate(S_m_IB(mx, my, nsx))
+ allocate(SIh_IB(mx, my, nsx))
+ allocate(S_h_IB(mx, my, nsx))
+ allocate(SSh_IB(mx, my, nsx))
+ allocate(wet_IB(mx, my, nsx))
+ allocate(wet0IB(mx, my, nsx))
+ allocate(wee_IB(mx, my, nsx, 4))
+ allocate(wee0IB(mx, my, nsx, 4))
+ allocate(wem_IB(mx, my, nsx))
+ allocate(wem0IB(mx, my, nsx))
+ allocate(wer_IB(mx, my, nsx))
+ allocate(wer0IB(mx, my, nsx))
+ allocate(weu_IB(mx, my, nsx))
+ allocate(weu0IB(mx, my, nsx))
+ allocate(weo_IB(mx, my, nsx, 6))
+ allocate(weo0IB(mx, my, nsx, 6))
+ allocate(wec0IB(mx, my, nsx))
+ allocate(wel0IB(mx, my, nsx))
+ allocate(snf_IB(mx, my, ml))
+ allocate(snf0IB(mx, my, ml))
+ allocate(sbl_IB(mx, my, ml))
+ allocate(sbl0IB(mx, my, ml))
+ allocate(qssbl_IB(mx, my, ml))
+ allocate(qssbl0IB(mx, my, ml))
+ allocate(dep_IB(mx, my, ml))
+ allocate(dep0IB(mx, my, ml))
+ allocate(rnf_IB(mx, my, ml))
+ allocate(rnf0IB(mx, my, ml))
+ allocate(evp_IB(mx, my, ml))
+ allocate(evp0IB(mx, my, ml))
+ allocate(werr0IB(mx, my))
+ allocate(wesf0IB(mx, my))
+ allocate(wecp0IB(mx, my))
+ allocate(wero0IB(mx, my))
+ allocate(wecr0IB(mx, my))
+ allocate(wesw0IB(mx, my, nsx))
+ allocate(wei0IB(mx, my, nsx))
+ allocate(weacIB(mx, my, nsx))
+ allocate(weac0IB(mx, my, nsx))
+ allocate(weerIB(mx, my, nsx))
+ allocate(weer0IB(mx, my, nsx))
+ allocate(mintIB(mx, my, ml))
+ allocate(maxtIB(mx, my, ml))
+ allocate(maxwIB(mx, my, ml))
+ allocate(ttIB(mx, my, ml))
+ allocate(tdIB(mx, my, ml))
+ allocate(uuIB(mx, my, ml))
+ allocate(vvIB(mx, my, ml))
+ allocate(uvIB(mx, my, ml))
+ allocate(wwIB(mx, my, ml))
+ allocate(psigIB(mx, my, ml))
+ allocate(wsigIB(mx, my, ml))
+ allocate(ruuIB(mx, my, ml))
+ allocate(rotuuIB(mx, my, mz))
+ allocate(rotvvIB(mx, my, mz))
+ allocate(rvvIB(mx, my, ml))
+ allocate(ruvIB(mx, my, ml))
+ allocate(qqIB(mx, my, ml))
+ allocate(rolvIB(mx, my, ml))
+ allocate(rhIB(mx, my, ml))
+ allocate(zzIB(mx, my, ml))
+ allocate(smt_IB(mx, my, ml))
+ allocate(smt0IB(mx, my, ml))
+ allocate(pddIB(mx, my))
+ allocate(spIB(mx, my))
+ allocate(slpIB(mx, my))
+ allocate(ccIB(mx, my))
+ allocate(cuIB(mx, my))
+ allocate(cmIB(mx, my))
+ allocate(cdIB(mx, my))
+ allocate(codIB(mx, my))
+ allocate(qwIB(mx, my))
+ allocate(qiIB(mx, my))
+ allocate(qsIB(mx, my))
+ allocate(qrIB(mx, my))
+ allocate(wvpIB(mx, my))
+ allocate(cwpIB(mx, my))
+ allocate(iwpIB(mx, my))
+ allocate(rhodzIB(mx, my, ml))
+ allocate(tcwvIB(mx, my))
+ allocate(tclcIB(mx, my))
+ allocate(tcicIB(mx, my))
+ allocate(tclpIB(mx, my))
+ allocate(tcipIB(mx, my))
+ allocate(pblIB(mx, my, nsx))
+ allocate(lqsIB(mx, my, ml))
+ allocate(lqiIB(mx, my, ml))
+ allocate(lqrIB(mx, my, ml))
+ allocate(lqwIB(mx, my, ml))
+ allocate(qsbIB(mx, my, ml))
+ allocate(lsbIB(mx, my, ml))
+ allocate(tkeIB(mx, my, ml))
+ allocate(qbrIB(mx, my))
+ allocate(swn3DIB(mx, my, ml))
+ allocate(lwn3DIB(mx, my, ml))
+ allocate(swnc3DIB(mx, my, ml))
+ allocate(lwnc3DIB(mx, my, ml))
+ allocate(cod3DIB(mx, my, ml))
+ allocate(cc3DIB(mx, my, ml))
+ allocate(ttbIB(mx, my, mlb))
+ allocate(txbIB(mx, my, mlb))
+ allocate(tnbIB(mx, my, mlb))
+ allocate(qqbIB(mx, my, mlb))
+ allocate(uubIB(mx, my, mlb))
+ allocate(vvbIB(mx, my, mlb))
+ allocate(uvbIB(mx, my, mlb))
+ allocate(zzbIB(mx, my, mlb))
+ allocate(tnh(mx, my, mlhh))
+ allocate(txh(mx, my, mlhh))
+ allocate(tdh(mx, my, mlhh))
+ allocate(uuh(mx, my, mlhh))
+ allocate(vvh(mx, my, mlhh))
+ allocate(slth(mx, my, mlhh))
+ allocate(slqch(mx, my, mlhh))
+ allocate(wvph(mx, my, mlhh))
+ allocate(cphIB(mx, my, mlhh))
+ allocate(cph0IB(mx, my))
+ allocate(wehIB(mx, my, mlhh))
+ allocate(weh0IB(mx, my, nsx))
+ allocate(ztdh(mx, my, mlhh))
+ allocate(zhdh(mx, my, mlhh))
+ allocate(zwdh(mx, my, mlhh))
+ allocate(tmh(mx, my, mlhh))
+ allocate(capeh(mx, my, mlhh))
+ allocate(ssth(mx, my, mlhh))
+ allocate(sphIB(mx, my, mlhh))
+ allocate(sthIB(mx, my, mlhh))
+ allocate(tthIB(mx, my, mlhh))
+ allocate(txhIB(mx, my, mlhh))
+ allocate(txhIB0(mx, my))
+ allocate(tnhIB(mx, my, mlhh))
+ allocate(tnhIB0(mx, my))
+ allocate(qqhIB(mx, my, mlhh))
+ allocate(uuhIB(mx, my, mlhh))
+ allocate(vvhIB(mx, my, mlhh))
+ allocate(swdhIB(mx, my, mlhh))
+ allocate(lwdhIB(mx, my, mlhh))
+ allocate(lwuhIB(mx, my, mlhh))
+ allocate(shfhIB(mx, my, mlhh))
+ allocate(lhfhIB(mx, my, mlhh))
+ allocate(alhIB(mx, my, mlhh))
+ allocate(prhIB(mx, my, mlhh))
+ allocate(rfhIB(mx, my, mlhh))
+ allocate(prh0IB(mx, my))
+ allocate(snfhIB(mx, my, mlhh))
+ allocate(snfh0IB(mx, my))
+ allocate(clhIB(mx, my, mlhh))
+ allocate(mehIB(mx, my, mlhh))
+ allocate(meh0IB(mx, my))
+ allocate(suhIB(mx, my, mlhh))
+ allocate(suh0IB(mx, my))
+ allocate(ruhIB(mx, my, mlhh))
+ allocate(ruh0IB(mx, my))
+ allocate(smbhIB(mx, my, mlhh))
+ allocate(smbh0IB(mx, my))
+ allocate(swhIB(mx, my, mlhh))
+ allocate(swh0IB(mx, my))
+ allocate(lwc1mhIB(mx, my, mlhh))
+ allocate(lwc2mhIB(mx, my, mlhh))
+ allocate(t5hIB(mx, my, mlhh))
+ allocate(u5hIB(mx, my, mlhh))
+ allocate(v5hIB(mx, my, mlhh))
+ allocate(q5hIB(mx, my, mlhh))
+ allocate(p5hIB(mx, my, mlhh))
+ allocate(nbpIB(mx, my, mp))
+ allocate(ttpIB(mx, my, mp))
+ allocate(qqpIB(mx, my, mp))
+ allocate(zzpIB(mx, my, mp))
+ allocate(uupIB(mx, my, mp))
+ allocate(vvpIB(mx, my, mp))
+ allocate(wwpIB(mx, my, mp))
+ allocate(uvpIB(mx, my, mp))
+ allocate(tairDYp(mx, my, mp))
+ allocate(gplvDYp(mx, my, mp))
+ allocate(qvDYp(mx, my, mp))
+ allocate(uairDYp(mx, my, mp))
+ allocate(vairDYp(mx, my, mp))
+ allocate(wairDYp(mx, my, mp))
+ allocate(ttzIB(mx, my, mztq))
+ allocate(qqzIB(mx, my, mztq))
+ allocate(rhzIB(mx, my, mztq))
+ allocate(uuzIB(mx, my, mzuv))
+ allocate(vvzIB(mx, my, mzuv))
+ allocate(uvzIB(mx, my, mzuv))
+ allocate(u2zIB(mx, my, mzuv))
+ allocate(v2zIB(mx, my, mzuv))
+ allocate(rozIB(mx, my, mzuv))
+ allocate(ttzIB_0(mx, my, mztq))
+ allocate(qqzIB_0(mx, my, mztq))
+ allocate(rhzIB_0(mx, my, mztq))
+ allocate(uuzIB_0(mx, my, mzuv))
+ allocate(vvzIB_0(mx, my, mzuv))
+ allocate(uvzIB_0(mx, my, mzuv))
+ allocate(u2zIB_0(mx, my, mzuv))
+ allocate(v2zIB_0(mx, my, mzuv))
+ allocate(ppzIB_0(mx, my, mztq))
+ allocate(rozIB_0(mx, my, mzuv))
+ allocate(swdIB(mx, my))
+ allocate(swuIB(mx, my))
+ allocate(lwdIB(mx, my))
+ allocate(lwuIB(mx, my))
+ allocate(sunIB(mx, my))
+ allocate(swdtIB(mx, my))
+ allocate(swutIB(mx, my))
+ allocate(lwutIB(mx, my))
+ allocate(shfIB(mx, my))
+ allocate(lhfIB(mx, my))
+ allocate(alIB(mx, my))
+ allocate(al1IB(mx, my, nsx))
+ allocate(al2IB(mx, my, nsx))
+ allocate(frvIB(mx, my, nsx))
+ allocate(stIB(mx, my))
+ allocate(st2IB(mx, my, nsx))
+ allocate(z0IB(mx, my, nsx))
+ allocate(r0IB(mx, my, nsx))
+ allocate(uusIB(mx, my, nsx))
+ allocate(utsIB(mx, my, nsx))
+ allocate(uqsIB(mx, my, nsx))
+ allocate(ussIB(mx, my, nsx))
+ allocate(uusthIB(mx, my, nsx))
+ allocate(sltIB(mx, my, nsx, nsol + 1))
+ allocate(slqIB(mx, my, nsx, nsol + 1))
+ allocate(slqcIB(mx, my, nsx))
+ allocate(slqmIB(mx, my, nsx))
+ allocate(sicIB(mx, my))
+ allocate(alb1IB(mx, my))
+ allocate(as1_IB(mx, my))
+ allocate(alb2IB(mx, my))
+ allocate(as2_IB(mx, my))
+ allocate(alb3IB(mx, my))
+ allocate(as3_IB(mx, my))
+ allocate(gradTIB(mx, my))
+ allocate(maxgrTIB(mx, my))
+ allocate(mingrTIB(mx, my))
+ allocate(gradQIB(mx, my))
+ allocate(maxgrQIB(mx, my))
+ allocate(mingrQIB(mx, my))
+ allocate(tt_intIB(mx, my, mw))
+ allocate(qq_intIB(mx, my, mw))
+ allocate(agIB(mx, my, nsx, mi))
+ allocate(g1IB(mx, my, nsx, mi))
+ allocate(g2IB(mx, my, nsx, mi))
+ allocate(roIB(mx, my, nsx, mi))
+ allocate(tiIB(mx, my, nsx, mi))
+ allocate(waIB(mx, my, nsx, mi))
+ allocate(zn0IB(mx, my, nsx))
+ allocate(zn1IB(mx, my, nsx))
+ allocate(zn2IB(mx, my, nsx))
+ allocate(zn3IB(mx, my, nsx))
+ allocate(zn4IB(mx, my, nsx))
+ allocate(zn5IB(mx, my, nsx))
+ allocate(zn6IB(mx, my, nsx))
+ allocate(mb0IB(mx, my, nsx))
+ allocate(mbIB(mx, my, nsx))
+ allocate(st2aoIB(mx, my, nsx))
+ allocate(sicaoIB(mx, my))
+ allocate(albaoIB(mx, my, nsx))
+ allocate(sitaoIB(mx, my))
+ allocate(sntaoIB(mx, my))
+
+ endsubroutine mar_ib_init
+
+endmodule mar_ib
diff --git a/MAR/code_mar/mar_io_mod.f90 b/MAR/code_mar/mar_io_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0f8203c8ceefab45d45768ce41e8ec30c5792193
--- /dev/null
+++ b/MAR/code_mar/mar_io_mod.f90
@@ -0,0 +1,42 @@
+! mar_io
+! ======
+module mar_io
+ implicit none
+ ! explIO: Experiment Label
+ character(len=3), save :: explIO
+ ! igrdIO: i (x-direc.) Index Ref. Grid Point (for detailed Output)
+ integer, save :: igrdIO(5)
+ ! jgrdIO: j (y-direc.) Index Ref. Grid Point (for detailed Output)
+ integer, save :: jgrdIO(5)
+ integer, save :: IO_gen
+ ! IO_loc = 1 : Initialisation: General: sigma, z_amsl, (ug,vg)
+ ! 2 : Initialisation: Details: Soundings (Ref.)
+ ! Insolation (PHYrad_top) (Synop)
+ ! Radiative Transfer (PHYrad_int) (Ref. ,Synop)
+ ! Turbulent Transfer (turtke_gen) (Ref.!,Synop)
+ ! Polynyas (SRFmod_pol) (RES. ,Synop)
+ ! Snow Pack (SRFmod_sno) (Ref. ,Synop)
+ ! Surface Energy Balance (SRFfrm_xxx) (Ref. ,Synop)
+ ! Surface Mass Balance (OUTice) (Synop)
+ ! 3 : Blowing Snow (HYDblo) (Ref.!,Synop)
+ ! Cloud mPhy (HYDmic) (Ref. ,Synop)
+ ! Polynyas (SRFmod_pol) (Synop)
+ ! 7 : Surface Turbulent Flux (TURsbl)
+ integer, save :: IO_loc
+ ! mxw1IO, mxw2IO, ixw_IO: x-domain to be printed (from mxw1 to mxw2 by ixw)
+ integer, save :: mxw1IO
+ integer, save :: mxw2IO
+ integer, save :: ixw_IO
+ ! myw1IO, myw2IO, iyw_IO: y-domain to be printed (from myw1 to myw2 by iyw)
+ integer, save :: myw1IO
+ integer, save :: myw2IO
+ integer, save :: iyw_IO
+ ! mzw1IO, mzw2IO, izw_IO: z-domain to be printed (from mzw1 to mzw2 by izw)
+ integer, save :: mzw1IO
+ integer, save :: mzw2IO
+ integer, save :: izw_IO
+ ! kkatIO : Low Level scaned in the meso animation
+ integer, save :: kkatIO
+ ! kmidIO : Mid Level scaned in the meso animation
+ integer, save :: kmidIO
+endmodule mar_io
diff --git a/MAR/code_mar/mar_lb_mod.f90 b/MAR/code_mar/mar_lb_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..47878bf15daab4abac7f9d3435d8c72e7bdbc6ff
--- /dev/null
+++ b/MAR/code_mar/mar_lb_mod.f90
@@ -0,0 +1,94 @@
+! mar_lb : mar lateral boundaries
+module mar_lb
+ use mardim
+ implicit none
+ ! n6 et n7 determine a relaxation zone towards lateral boundaries
+ ! (large scale values of the variables).
+ ! This zone extends over n6-1 points.
+ ! Davies (1976) propose 5 points (i.e. n6=6 and n7=7)
+ ! iyr_LB: Year
+ integer, save :: iyr_LB
+ ! mma_LB: Month
+ integer, save :: mma_LB
+ ! jda_LB: Day
+ integer, save :: jda_LB
+ ! jhu_LB: Hour (UT)
+ integer, save :: jhu_LB
+ ! jdh_LB: Time Interval before next GCM/NWP LBC (hour)
+ ! jdh_LB=0 ==> NO further GCM/NWP LBC available
+ integer, save :: jdh_LB
+ ! tim1LB: Time of the previous LBC (second)
+ integer(kind=8), save :: tim1LB
+ ! tim2LB: Time of the next LBC (second)
+ integer(kind=8), save :: tim2LB
+ ! n6mxLB, n6myLB, ... define the effective length of the lateral sponge
+ integer, save :: n40xLB, n50xLB, n5mxLB, n6mxLB, n7mxLB, &
+ n40yLB, n50yLB, n5myLB, n6myLB, n7myLB
+ ! vaXX : large scale values of relevant dependant variables
+ ! ^X=(x->x axis border, y->y axis border)
+ ! ^X=(g->x small, d->x large, b->y small, h->y large)
+ real, save, allocatable :: vaxgLB(:, :, :, :)
+ real, save, allocatable :: vaxdLB(:, :, :, :)
+ real, save, allocatable :: v1xgLB(:, :, :, :)
+ real, save, allocatable :: v1xdLB(:, :, :, :)
+ real, save, allocatable :: v2xgLB(:, :, :, :)
+ real, save, allocatable :: v2xdLB(:, :, :, :)
+ real, save, allocatable :: tixgLB(:, :, :)
+ real, save, allocatable :: tixdLB(:, :, :)
+ real, save, allocatable :: vayiLB(:, :, :, :)
+ real, save, allocatable :: vaysLB(:, :, :, :)
+ real, save, allocatable :: v1yiLB(:, :, :, :)
+ real, save, allocatable :: v1ysLB(:, :, :, :)
+ real, save, allocatable :: v2yiLB(:, :, :, :)
+ real, save, allocatable :: v2ysLB(:, :, :, :)
+ ! tiXXLB : independant term of semi-implicit numerical scheme
+ real, save, allocatable :: tiyiLB(:, :, :)
+ real, save, allocatable :: tiysLB(:, :, :)
+ ! wiXXLB : coefficient used in semi-implicit numerical scheme
+ real, save, allocatable :: wixgLB(:, :)
+ real, save, allocatable :: wixdLB(:, :)
+ real, save, allocatable :: wiyiLB(:, :)
+ real, save, allocatable :: wiysLB(:, :)
+ ! rXLB : nudging coefficients of the relaxation zone
+ real, save :: rxLB(mx)
+ real, save :: ryLB(my)
+ ! sst_LB : external SST
+ real, save :: sst_LB(mx, my)
+ real, save :: sst1LB(mx, my)
+ real, save :: sst2LB(mx, my)
+ ! Tfr_LB : Freezing Temperature
+ ! (corrected when using Reynolds data set)
+ real, save :: Tfr_LB
+
+contains
+
+ subroutine mar_lb_init()
+
+ use mardim, only: mx, my, mz,n7,n6
+ implicit none
+
+ allocate(vaxgLB(1:n7, my, mz, 5))
+ allocate(vaxdLB(mx - n6:mx, my, mz, 5))
+ allocate(v1xgLB(1:n7, my, mz, 5))
+ allocate(v1xdLB(mx - n6:mx, my, mz, 5))
+ allocate(v2xgLB(1:n7, my, mz, 5))
+ allocate(v2xdLB(mx - n6:mx, my, mz, 5))
+ allocate(tixgLB(2:n7, my, mz))
+ allocate(tixdLB(mx - n6:mx1, my, mz))
+ allocate(vayiLB(mx, 1:n7, mz, 5))
+ allocate(vaysLB(mx, my - n6:my, mz, 5))
+ allocate(v1yiLB(mx, 1:n7, mz, 5))
+ allocate(v1ysLB(mx, my - n6:my, mz, 5))
+ allocate(v2yiLB(mx, 1:n7, mz, 5))
+ allocate(v2ysLB(mx, my - n6:my, mz, 5))
+ allocate(tiyiLB(mx, 2:n7, mz))
+ allocate(tiysLB(mx, my - n6:my1, mz))
+ allocate(wixgLB(2:n7, 2:n7))
+ allocate(wixdLB(mx - n6:mx1, mx - n6:mx1))
+ allocate(wiyiLB(2:n7, 2:n7))
+ allocate(wiysLB(my - n6:my1, my - n6:my1))
+
+ endsubroutine mar_lb_init
+
+
+endmodule mar_lb
diff --git a/MAR/code_mar/mar_module.f90 b/MAR/code_mar/mar_module.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7997fb41cc007aee283fc4c653c67f33f3499200
--- /dev/null
+++ b/MAR/code_mar/mar_module.f90
@@ -0,0 +1,526 @@
+module mar_module
+ use mardim
+ use mar_ge
+ use marphy
+ use mar_ao
+ implicit none
+ private
+ public :: inicma, fromcpl, intocpl, atm2geo, atm2geo2
+ integer, parameter, public :: im = mx, jm = my
+ integer, parameter, public :: ntot = mx * my
+ integer, parameter, public :: nout = 6
+ ! i_timemax : Nombre de pas de temps dans les fichiers Netcdf de forcage
+ integer, parameter, public :: i_timemax = 30
+ ! i_ReadFieldNb : Nombre de champs du fichier Netcdf de forcage
+ integer, parameter, public :: i_ReadFieldNb = 11
+ ! i_WriteFieldNb : Nombre de champs du fichier Netcdf de sorties oceaniques
+ integer, parameter, public :: i_WriteFieldNb = 5
+ ! jpflda2o1 : Number of fields exchanged from atmosphere to ocean via flx.F
+ integer, parameter, public :: jpflda2o1 = 9 !9 if coupsnow // 8 if not
+ ! jpflda2o2 : Number of fields exchanged from atmosphere to ocean via tau.F
+ integer, parameter, public :: jpflda2o2 = 8 !!COTAU...
+ ! jpfldo2a : Number of fields exchanged from ocean to atmosphere
+ integer, parameter, public :: jpfldo2a = 10
+ ! Define symbolic name for fields exchanged from atmos to coupler,
+ ! must be the same as (1) of the field definition in namcouple:
+ ! real, dimension(im,jm), save :: uuao,vvao
+ ! character(len=8), parameter, dimension(16), public :: cl_writ=(/ 'COSHFICE', &
+ ! & 'COSHFOCE', 'CONSFICE', 'CONSFOCE', 'CODFLXDT', 'COEVAPWA', 'COLIQPRE', &
+ ! & 'COSOLPRE', 'COTAUXUW', 'COTAUXUI', 'COTAUYUW', &
+ ! & 'COTAUYUI', 'COTAUXVW', 'COTAUXVI', 'COTAUYVW', 'COTAUYVI' /)
+ !avec coupsnow
+ character(len=8), parameter, dimension(17), public :: cl_writ = (/ &
+ 'COSHFICE', 'COSHFOCE', 'CONSFICE', 'CONSFOCE', 'CODFLXDT', &
+ 'COEVATOT', 'COLIQPRE', 'COSOLPRE', 'COEVAICE', 'COTAUXUW', &
+ 'COTAUXUI', 'COTAUYUW', 'COTAUYUI', 'COTAUXVW', 'COTAUXVI', &
+ 'COTAUYVW', 'COTAUYVI'/)
+ ! COSHFICE = COupled Solar Heat Flux on ICE (SWD on ice)
+ ! COSHFOCE = COupled Solar Heat Flux on OCEan (SWD on ice)
+ ! CONSFICE = COupled Non Solar Flux on ICE (LWD on ice)
+ ! CONSFOCE = Coupled Non Solar Flux on OCEan (LWD on ocean)
+ ! CODFLXDT = COupled down Latent x(?) DerivaTive
+ ! COEVAPWA = COupled EVAPoration on WAter
+ ! COLIQPRE = COupled LIQuid PREcipitation
+ ! COSOLPRE = COupled SOLid PREcipitation
+ ! COUPSNOW = COupled UPward Snow !BS
+ ! COTAUXUW = COupled downward TAUx X-axis X-axis stress on U-grid on Water
+ ! COTAUXUI = COupled downward TAUx X-axis X-axis stress on U-grid on Ice
+ ! COTAUYUW = COupled downward TAUx X-axis Y-axis stress on U-grid on Water
+ ! COTAUYUI = COupled downward TAUx X-axis Y-axis stress on U-grid on Ice
+ ! COTAUXVW = COupled downward TAUx X-axis X-axis stress on V-grid on Water
+ ! COTAUXVI = COupled downward TAUx X-axis X-axis stress on V-grid on Ice
+ ! COTAUYVW = COupled downward TAUx X-axis Y-axis stress on U-grid on Water
+ ! COTAUYVI = COupled downward TAUx X-axis Y-axis stress on V-grid on Ice
+ !
+ ! Define symbolic name for fields exchanged from coupler to atmosphere,
+ ! must be the same as (2) of the field definition in namcouple:
+ character(len=8), parameter, dimension(10), public :: cl_read = (/ &
+ 'SISUTESW', 'SIICECOV', 'SIICEALW', 'SIICTEMW', 'SIHEIGHT', &
+ 'SISNOWHT', 'OCECURTU', 'OCECURTV', 'ICECURTU', 'ICECURTV'/)
+ integer, dimension(jpfldo2a), save :: ig_var_id_in
+ integer, dimension(jpflda2o1 + jpflda2o2), save :: ig_var_id_out
+
+contains
+ subroutine inicma
+ use mod_oasis
+ implicit none
+ ! comp_id : component identification
+ integer :: comp_id
+ character(len=6) :: comp_name = 'mara'
+ integer :: ierror
+ ! localComm : local MPI communicator and Initialized
+ integer :: localComm
+ ! Global grid parameters :
+ ! nlon, nlat : dimensions in the 2 directions of space
+ ! integer :: nlon, nlat
+ ! MAR Antarctic since first MAR-NEMO coupling over the AIS.
+ ! NB character(len=4) used for historical oasis reasons userguidep16
+ character(len=4) :: cgrid = 'mara'
+ ! ntot : total dimension (=mx*my) defined above
+ ! integer :: ntot
+ integer :: il_paral_size
+ ! nc : number of corners
+ ! integer :: nc
+ ! integer :: indi_beg, indi_end, indj_beg, indj_end
+
+ ! if OASIS has to define grids.nc, masks.nc and areas.nc (do not use it)
+ ! real :: deglon2D(mx,my),deglat2D(mx,my)
+ ! real :: globalgrid_clo(mx,my), globalgrid_cla(mx,my), globalgrid_srf(mx,my),indice_mask(mx,my)
+
+ ! il_paral : Decomposition for each proc !cf uiserguide p12
+ integer, dimension(:), ALLOCATABLE :: il_paral
+
+ ! Grid parameters definition
+ ! il_part_id : use to connect the partition to the variables
+ integer :: il_part_id
+
+ ! some messy paramaters still not classified
+ ! il_flag : Flag for grid writing by proc 0
+ integer :: il_flag
+ integer il_var_nodims(2), il_var_shape(4)
+ integer jf, info
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !* 1. Initializations
+ ! ---------------
+
+ write(nout, *) ' '
+ write(nout, *) ' '
+ write(nout, *) ' ROUTINE INICMA'
+ write(nout, *) ' **************'
+ write(nout, *) ' '
+ write(nout, *) ' '
+
+ call oasis_init_comp(comp_id, comp_name, ierror) ! model name = MAR
+
+ if(ierror /= 0) then
+ write(6, *) 'oasis_init_comp abort by ', comp_name, ' compid ', comp_id
+ call oasis_abort(comp_id, comp_name, 'Problem init in oasis_init_comp')
+ else
+ write(6, *) 'inicma: init oasis ok'
+ endif
+
+ !* 1.1 Oasis get localcomm
+ ! ---------------
+ ! Attribution by Oasis of a local communicator for each component
+ !WARNING WARNING!
+ call oasis_get_localcomm(localComm, ierror)
+ if(ierror /= 0) then
+ write(6, *) 'oasis_get_localcomm abort by', comp_name, ' compid ', comp_id
+ call oasis_abort(comp_id, comp_name, 'Problem ')
+ endif
+
+ !Probably not Needed (at least it works without...)
+ ! call MPI_Comm_Size ( localComm, npes, ierror )
+ ! if (ierror /= 0) then
+ ! write(w_unit,*) 'MPI_comm_size abort by model1 compid ',comp_id
+ ! call oasis_abort(comp_id,comp_name,'Problem at line 131')
+ ! end if
+ ! !
+ ! call MPI_Comm_Rank ( localComm, mype, ierror )
+ ! if (ierror /= 0) then
+ ! write (w_unit,*) 'MPI_Comm_Rank abort by model1 compid ',comp_id
+ ! call oasis_abort(comp_id,comp_name,'Problem at line 137')
+ ! end if
+
+ !* 1.2 Grid partition
+ ! ---------------
+ ! Definition of the partition of the grid (serial, apple, box and orange)
+ ! CHECK for OPEN-MP/ MPI compatibility !!!! CK 20/02/2020
+ ! Firsly coded to use a serial partition (= no partition) = one box
+ ! works but only with one CPU (probably link to oasis get localcomm?)
+
+ ! ntot = mx * my ! mx and my from mardim_mod.f90
+
+ ! il_paral_size = 3 ! for apple
+ ! il_paral_size = 5 ! for box
+ ! il_paral_size = ! N segments for orange
+ ! il_paral_size = ! N points for points
+ il_paral_size = 3 !no partition Serial userguide p12
+ ALLOCATE(il_paral(il_paral_size))
+
+ !WARNING!!! if Serial
+ if(il_paral_size == 3) then
+ il_paral(1) = 0
+ il_paral(2) = 0
+ il_paral(3) = ntot
+ endif
+
+ call oasis_def_partition(il_part_id, il_paral, ierror)
+
+ DEALLOCATE(il_paral)
+
+ !* 1.3 Grid definition
+ ! ---------------
+ ! Definition of grids (grids.nc, masks.nc and areas.nc) if not previously defined by users
+ ! => do IT AND do NOT LET OASIS TO do IT
+
+ ! deglon2D = GElonh * 15. !Gelonh(mx,my) = longitude in hours
+ ! deglat2D = GElatr / degrad !Gelatr(mx,my) = lat in radian
+ ! should be corrected as OASIS needs lon and lat corner not lon and lat from the center of the pixel !CK6/12/18
+
+ ! call oasis_start_grids_writing(il_flag)
+ ! call oasis_write_grid(cgrid, mx, my, deglon2D, deglat2D)
+ ! call oasis_write_corner(cgrid, mx, my, 4, globalgrid_clo, globalgrid_cla)
+ ! call oasis_write_area(cgrid, mx, my, globalgrid_srf)
+ ! call oasis_write_mask(cgrid, mx, my, indice_mask(:,:))
+ ! call oasis_terminate_grids_writing()
+
+ !* 1.4 Coupling field declaration
+ ! ---------------
+ il_var_nodims(1) = 1
+ il_var_nodims(2) = 1
+
+ il_var_shape(1) = 1
+ il_var_shape(2) = mx
+ il_var_shape(3) = 1
+ il_var_shape(4) = my
+
+ ! 1.4.1 Declare each field received by atm
+
+ do jf = 1, jpfldo2a
+ call oasis_def_var(ig_var_id_in(jf), cl_read(jf), il_part_id, il_var_nodims, &
+ OASIS_In, il_var_shape, OASIS_real, ierror)
+ !var_id, name= nom namcouple, partition ID, varnodims always 1,
+ ! OASIS_in defined in parameters.f90 (see userguide p18),dimension,type du field,
+ if(ierror /= 0) then
+ write(6, *) ' inicma : pb o define O to A ' &
+ &, cl_read(jf), ' for jf = ', jf
+ write(6, *) ' error code is = ', ierror
+ write(6, *) ' STOP in inicma'
+ call FLUSH(6)
+ call abort
+ else
+ write(6, *) 'inicma : oasis define O to A OK ', jf, ' : ' &
+ &, cl_read(jf)
+ endif
+ enddo
+
+ ! 1.4.2 Declare each field sent by atm
+
+ do jf = 1, jpflda2o1 + jpflda2o2
+ call oasis_def_var(ig_var_id_out(jf), cl_writ(jf), il_part_id, il_var_nodims, &
+ OASIS_Out, il_var_shape, OASIS_real, ierror)
+
+ if(ierror /= 0) then
+ write(6, *) ' inicma : pb oasis def var A to O ' &
+ &, cl_writ(jf), ' for jf = ', jf
+ write(6, *) ' error code is = ', ierror
+ write(6, *) ' STOP in inicma'
+ call FLUSH(6)
+ call abort
+ else
+ write(6, *) 'inicma : oasis define OK A to O ', jf, ' : ' &
+ &, cl_writ(jf)
+ endif
+ enddo
+ write(6, *) 'inicma : oasis_def_var ok '
+
+ !* 1.5 end of declaration phase
+ ! ---------------
+
+ call oasis_enddef(ierror)
+
+ if(ierror /= 0) then
+ write(6, *) 'inicma : pb oasis_enddef '
+ write(6, *) ' error code is = ', ierror
+ write(6, *) ' STOP in inicma'
+ coupling_ao = .false.
+ call FLUSH(6)
+ call abort
+ else
+ write(6, *) 'inicma : start ierror ok '
+ coupling_ao = .true.
+ endif
+
+ endsubroutine inicma
+
+ !==========================================================================
+ !
+ subroutine fromcpl(kt, sst, iss, gla, igla, albedo, ialb, tice, itic, hice, ihic, &
+ hsnow, ihsn, u_oce, i_uo, v_oce, i_vo, u_ice, i_ui, v_ice, i_vi)
+
+ use mod_oasis
+
+ implicit none
+
+ integer kt ! in seconds
+ real(kind=8) sst(im, jm) ! -sea-surface-temperature
+ real(kind=8) gla(im, jm) ! -sea-ice fraction
+ real(kind=8) tice(im, jm) ! -ice surf temperature
+ real(kind=8) albedo(im, jm) ! -albedo over sea ice
+ real(kind=8) hice(im, jm) ! -sea ice height
+ real(kind=8) hsnow(im, jm) ! -surface snow thickness over sea ice
+ real(kind=8) u_oce(im, jm) ! -surface ocean velocity along X
+ real(kind=8) v_oce(im, jm) ! -surface ocean velocity along Y
+ real(kind=8) u_ice(im, jm) ! -surface ice velocity along X
+ real(kind=8) v_ice(im, jm) ! -surface ice velocity along Y
+
+ integer info, jf
+ ! flag used in MAR so that MAR can know if there was a coupling
+ ! for that variable at its timestep
+ integer iss, igl, igla, ialb, itic, ihic, ihsn, i_uo, i_vo, i_ui, i_vi
+
+ call flush(6)
+
+ ! Get interpolated oceanic fields from Oasis
+ ! (only if kt=coupling time, cf oasis_get_proto)
+
+ do jf = 1, jpfldo2a
+ if(jf == 1) then
+ call oasis_get(ig_var_id_in(1), kt, sst, iss)
+ info = iss
+ endif
+ if(jf == 2) then
+ call oasis_get(ig_var_id_in(2), kt, gla, igla)
+ info = igla
+ endif
+ if(jf == 3) then
+ call oasis_get(ig_var_id_in(3), kt, albedo, ialb)
+ info = ialb
+ endif
+ if(jf == 4) then
+ call oasis_get(ig_var_id_in(4), kt, tice, itic)
+ info = itic
+ endif
+ if(jf == 5) then
+ call oasis_get(ig_var_id_in(5), kt, hice, ihic)
+ info = ihic
+ endif
+ if(jf == 6) then
+ call oasis_get(ig_var_id_in(6), kt, hsnow, ihsn)
+ info = ihsn
+ endif
+ if(jf == 7) then
+ call oasis_get(ig_var_id_in(7), kt, u_oce, i_uo)
+ info = i_uo
+ endif
+ if(jf == 8) then
+ call oasis_get(ig_var_id_in(8), kt, v_oce, i_vo)
+ info = i_vo
+ endif
+
+ if(jf == 9) then
+ call oasis_get(ig_var_id_in(9), kt, u_ice, i_ui)
+ info = i_ui
+ endif
+
+ if(jf == 10) then
+ call oasis_get(ig_var_id_in(10), kt, v_ice, i_vi)
+ info = i_vi
+ endif
+
+ if(info /= OASIS_Ok .and. info /= OASIS_Recvd &
+ & .and. info /= OASIS_FromRest .and. info /= OASIS_Input &
+ & .and. info /= OASIS_RecvOut .and. &
+ & info /= OASIS_FromRestOut) then
+ write(nout, *) 'Pb in reading ', cl_read(jf), jf
+ write(nout, *) 'Couplage kt is = ', kt
+ write(nout, *) 'PSMILe error code is = ', info
+ write(nout, *) ' STOP in fromcpl'
+ call FLUSH(nout)
+ call abort
+ endif
+ enddo
+
+ endsubroutine fromcpl
+ !
+ !==========================================================================
+ !
+ ! subroutine intocpl(kt, fsolice, fsolwat, fnsolice, fnsolwat, &
+ ! & fnsicedt, evwat, lpre, spre, &
+ ! & taux_u_oce, taux_u_ice, tauy_u_oce, tauy_u_ice, &
+ ! & taux_v_oce, taux_v_ice, tauy_v_oce, tauy_v_ice)
+
+ ! with upsnpw(coupsnow)
+
+ subroutine intocpl(kt, fsolice, fsolwat, fnsolice, fnsolwat, &
+ & fnsicedt, evtot, lpre, spre, ievp, &
+ & taux_u_oce, taux_u_ice, tauy_u_oce, tauy_u_ice, &
+ & taux_v_oce, taux_v_ice, tauy_v_oce, tauy_v_ice)
+
+ use mod_oasis
+
+ implicit none
+
+ ! time in seconds
+ integer, intent(in) :: kt
+ ! solar heat flux on sea ice
+ real(kind=8), dimension(im, jm), intent(in) :: fsolice
+ ! solar heat flux on water
+ real(kind=8), dimension(im, jm), intent(in) :: fsolwat
+ ! total non-solar heat flux on sea ice
+ real(kind=8), dimension(im, jm), intent(in) :: fnsolice
+ ! total non-solar heat flux on water
+ real(kind=8), dimension(im, jm), intent(in) :: fnsolwat
+ ! non solar heat flux derivative
+ real(kind=8), dimension(im, jm), intent(in) :: fnsicedt
+ ! evaporation over ocean and sea ice
+ real(kind=8), dimension(im, jm), intent(in) :: evtot
+ ! liquid precip
+ real(kind=8), dimension(im, jm), intent(in) :: lpre
+ ! snow fall
+ real(kind=8), dimension(im, jm), intent(in) :: spre
+ ! sea ice sublimation
+ real(kind=8), dimension(im, jm), intent(in) :: ievp
+ ! weighted surface downward X-axis stress on U-grid
+ real(kind=8), dimension(im, jm), intent(in) :: taux_u_oce
+ ! weighted surface downward X-axis stress over ice on U-grid
+ real(kind=8), dimension(im, jm), intent(in) :: taux_u_ice
+ ! weighted surface downward Y-axis stress on U-grid
+ real(kind=8), dimension(im, jm), intent(in) :: tauy_u_oce
+ ! weighted surface downward Y-axis stress over ice on U-grid
+ real(kind=8), dimension(im, jm), intent(in) :: tauy_u_ice
+ ! weighted surface downward X-axis stress on V-grid
+ real(kind=8), dimension(im, jm), intent(in) :: taux_v_oce
+ ! weighted surface downward X-axis stress over ice on V-grid
+ real(kind=8), dimension(im, jm), intent(in) :: taux_v_ice
+ ! weighted surface downward Y-axis stress on V-grid
+ real(kind=8), dimension(im, jm), intent(in) :: tauy_v_oce
+ ! weighted surface downward Y-axis stress over ice on V-grid
+ real(kind=8), dimension(im, jm), intent(in) :: tauy_v_ice
+
+ integer :: icstep, info, jn
+ !
+ icstep = kt
+ !
+
+ !
+ ! -Give atmospheric fields to Oasis
+ ! (only if kt+idt=coupling time, cf prism_put_proto)
+ ! (else, prism_put_prot usefull for averages in oasis)
+
+ do jn = 1, jpflda2o1 + jpflda2o2
+ if(jn == 1) call oasis_put(ig_var_id_out(jn), &
+ & kt, fsolice, info)
+ if(jn == 2) call oasis_put(ig_var_id_out(jn), kt, &
+ & fsolwat, info)
+ if(jn == 3) call oasis_put(ig_var_id_out(jn), kt, &
+ & fnsolice, info)
+ if(jn == 4) call oasis_put(ig_var_id_out(jn), kt, &
+ & fnsolwat, info)
+ if(jn == 5) call oasis_put(ig_var_id_out(jn), kt, &
+ & fnsicedt, info)
+ if(jn == 6) call oasis_put(ig_var_id_out(jn), kt, &
+ & evtot, info)
+ if(jn == 7) call oasis_put(ig_var_id_out(jn), kt, &
+ & lpre, info)
+ if(jn == 8) call oasis_put(ig_var_id_out(jn), kt, &
+ & spre, info)
+ if(jn == 9) call oasis_put(ig_var_id_out(jn), kt, &
+ & ievp, info) !WARNING NOT useD ANYMORE 03/05 (CK? maybe still used actually)
+ if(jn == 10) call oasis_put(ig_var_id_out(jn), kt, &
+ & taux_u_oce, info)
+ if(jn == 11) call oasis_put(ig_var_id_out(jn), kt, &
+ & taux_u_ice, info)
+ if(jn == 12) call oasis_put(ig_var_id_out(jn), kt, &
+ & tauy_u_oce, info)
+ if(jn == 13) call oasis_put(ig_var_id_out(jn), kt, &
+ & tauy_u_ice, info)
+ if(jn == 14) call oasis_put(ig_var_id_out(jn), kt, &
+ & taux_v_oce, info)
+ if(jn == 15) call oasis_put(ig_var_id_out(jn), kt, &
+ & taux_v_ice, info)
+ if(jn == 16) call oasis_put(ig_var_id_out(jn), kt, &
+ & tauy_v_oce, info)
+ if(jn == 17) call oasis_put(ig_var_id_out(jn), kt, &
+ & tauy_v_ice, info)
+
+ if(info /= OASIS_Ok .and. info /= OASIS_Sent &
+ .and. info /= OASIS_ToRest .and. info /= OASIS_LocTrans &
+ .and. info /= OASIS_Output .and. info /= OASIS_SentOut &
+ .and. info /= OASIS_ToRestOut) then
+ write(nout, *) 'STEP : Pb giving ', cl_writ(jn), ':', jn
+ write(nout, *) ' at timestep = ', icstep, 'kt = ', kt
+ write(nout, *) 'OASIS error code is = ', info
+ write(nout, *) ' STOP in intocpl'
+ call FLUSH(nout)
+ call abort
+ endif
+ enddo
+ endsubroutine intocpl
+ !
+ !==========================================================================
+ !
+ subroutine atm2geo(pte, ptn, plon, plat, pxx, pyy, pzz)
+ !
+ !! Change wind local atmospheric coordinates to geocentric
+ !!
+ !
+ real, dimension(im, jm), intent(in) :: pte, ptn
+ real, dimension(im, jm), intent(in) :: plon, plat
+ real, dimension(im, jm), intent(out) :: pxx, pyy, pzz
+ !
+ real, parameter :: rpi = 3.141592653E0
+ real, parameter :: rad = rpi / 180.0E0
+ !
+ real, dimension(im, jm), save :: zsinlon, zcoslon
+ real, dimension(im, jm), save :: zsinlat, zcoslat
+ !
+ logical, save :: linit = .false.
+ !
+ if(.not. linit) then
+ zsinlon = SIN(rad * plon)
+ zcoslon = COS(rad * plon)
+ zsinlat = SIN(rad * plat)
+ zcoslat = COS(rad * plat)
+ linit = .true.
+ endif
+ !
+ pxx = -zsinlon * pte - zsinlat * zcoslon * ptn
+ pyy = zcoslon * pte - zsinlat * zsinlon * ptn
+ pzz = zcoslat * ptn
+ !
+ ! Value at North Pole
+ pxx(:, 1) = -ptn(1, 1)
+ pyy(:, 1) = -pte(1, 1)
+ pzz(:, 1) = 0.0
+ ! Value at South Pole
+ pxx(:, jm) = +ptn(1, jm)
+ pyy(:, jm) = +pte(1, jm)
+ pzz(:, jm) = 0.0
+ !
+ endsubroutine atm2geo
+
+ subroutine atm2geo2(ua, va, lon, uo, vo)
+ ! Reproj wind vectors from MAR grid to NEMO grid ... need to be improved ! PV
+ ! MAR uses wind_rot.f90 now
+
+ real, dimension(im, jm), intent(in) :: ua, va
+ real, dimension(im, jm), intent(in) :: lon
+ real, dimension(im, jm), intent(out) :: uo, vo
+ real, parameter :: rpi = 3.141592653E0
+ real, parameter :: rad = rpi / 180.0E0
+ real, dimension(im, jm), save :: cosphi, sinphi, phi
+ real, parameter :: lon0 = 140.0E0
+ real, parameter :: deltaphi = 90 - lon0
+
+ phi = -1 * (lon + deltaphi) * rad
+ cosphi = COS(phi)
+ sinphi = SIN(phi)
+
+ uo = sinphi * va + cosphi * ua
+ vo = cosphi * va - sinphi * ua
+ endsubroutine atm2geo2
+endmodule mar_module
diff --git a/MAR/code_mar/mar_nh_mod.f90 b/MAR/code_mar/mar_nh_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..354652b053fd63fe29a31e2628c53a29dec36448
--- /dev/null
+++ b/MAR/code_mar/mar_nh_mod.f90
@@ -0,0 +1,28 @@
+! mar_nh : mar non-hydrostatic
+! ============================
+module mar_nh
+ use mardim
+ implicit none
+ ! ua0_NH : Horizontal (x-Direction) Wind Speed (m/s) / Previous Time Step
+ real, save :: ua0_NH(mx, my, mz)
+ ! va0_NH : Horizontal (y-Direction) Wind Speed (m/s) / Previous Time Step
+ real, save :: va0_NH(mx, my, mz)
+ ! wa0_NH : Vertical (z-Direction) Wind Speed (m/s) / Previous Time Step
+ real, save :: wa0_NH(mx, my, mz)
+ ! wairNH : Vertical Non-Hydrostatic Wind Speed (m/s)
+ real, save :: wairNH(mx, my, mz)
+ ! pairNH : Non-Hydrostatic Pressure (kPa)
+ real, save :: pairNH(mx, my, mz)
+ ! dt_ONH : Non-Hydrostatic Time Step (s)
+ real, save :: dt_ONH
+ ! dtxONH = dt_ONH / dx (s/m)
+ real, save :: dtxONH
+ ! dtyONH = dt_ONH / dy (s/m)
+ real, save :: dtyONH
+ ! gamaNH : Cp / Cv
+ real, save :: gamaNH
+ ! c2NH : Prescribed Squared Sound Speed (m2/s2)
+ real, save :: c2NH
+ ! taNH : Reference Surface Air Temperature (K)
+ real, save :: taNH
+endmodule mar_nh
diff --git a/MAR/code_mar/mar_ol_mod.f90 b/MAR/code_mar/mar_ol_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..871689fae72e8c5f533f54de099be42c412af0af
--- /dev/null
+++ b/MAR/code_mar/mar_ol_mod.f90
@@ -0,0 +1,10 @@
+! mar_ol
+! ======
+module mar_ol
+ use mardim
+ implicit none
+ real, save :: urefOL(mx, my, mz)
+ real, save :: trefOL(mx, my, mz)
+ real, save :: gp00OL(mx, my, mz)
+ real, save :: gplvOL(mx, my, mz)
+endmodule mar_ol
diff --git a/MAR/code_mar/mar_pb_mod.f90 b/MAR/code_mar/mar_pb_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4f95a2231ed1b6c66eef67e597e8dd1fb030b8d4
--- /dev/null
+++ b/MAR/code_mar/mar_pb_mod.f90
@@ -0,0 +1,29 @@
+module mar_pb
+ use mardim
+ implicit none
+ ! Kstep1 : convective counter
+ integer, save :: Kstep1(klon)
+ ! K_CbT1 : cloud top level
+ integer, save :: K_CbT1(klon)
+ ! K_CbB1 : cloud base level
+ integer, save :: K_CbB1(klon)
+ integer, parameter :: KTCCH0 = 1
+ real, save :: P_CH_0(klon, klev, KTCCH0)
+ real, save :: PdCH_1(klon, klev, KTCCH0)
+ real, save :: PdTa_1(klon, klev)
+ real, save :: PdQa_1(klon, klev)
+ real, save :: PdQw_1(klon, klev)
+ real, save :: PdQi_1(klon, klev)
+ real, save :: Pdrr_1(klon)
+ real, save :: Pdss_1(klon)
+ ! PuMF_1 : Upward Mass Flux
+ real, save :: PuMF_1(klon, klev)
+ ! PdMF_1 : Downward Mass Flux
+ real, save :: PdMF_1(klon, klev)
+ ! Pfrr_1 : Liquid Precipitation Flux
+ real, save :: Pfrr_1(klon, klev)
+ ! Pfss_1 : Solid Precipitation Flux
+ real, save :: Pfss_1(klon, klev)
+ ! Pcape1 : CAPE [J/kg]
+ real, save :: Pcape1(klon)
+endmodule mar_pb
diff --git a/MAR/code_mar/mar_po_mod.f90 b/MAR/code_mar/mar_po_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9657ce65f26f4eb00ab29d6dc6bded03ebb804bd
--- /dev/null
+++ b/MAR/code_mar/mar_po_mod.f90
@@ -0,0 +1,56 @@
+! mar_po : mar polynya model
+! ==========================
+module mar_po
+ use mardim
+ implicit none
+ ! dtPO : Polynya Model Time Step
+ real, save :: dtPO
+ ! silfPO : Sea Ice Solidification: Latent Heat
+ real, save :: silfPO
+ ! sw00PO, si00PO: water, sea-ice salinities (TN Bay)
+ ! (Bromwich and Kurtz, 1984, JGR, p.3568;
+ ! Cavalieri and Martin, 1985, p. 248)
+ real, save :: sw00PO
+ real, save :: si00PO
+ ! aPOlyn : Initial (observed) Lead Fraction
+ real, save :: aPOlyn(mx, my)
+ ! iPO1,iPO2,iPO3,iPO4 define output area (x-axis)
+ ! jPO1,jPO2,jPO3,jPO4 define output area (y-axis)
+ integer, save :: iPO1, iPO2, jPO1, jPO2, iPO3, iPO4, jPO3, jPO4
+ ! uocnPO: Oceanic Current (prescribed, x-direction)
+ real, save :: uocnPO(mx, my)
+ ! vocnPO: Oceanic Current (prescribed, y-direction)
+ real, save :: vocnPO(mx, my)
+ ! focnPO: Oceanic Heat Flux (in the oceanic mixed layer)
+ real, save :: focnPO(mx, my)
+ ! albwPO: Open Water Surface Albedo
+ real, save :: albwPO(mx, my)
+ ! hatmPO: Heat Losses from Open Water Area
+ real, save :: hatmPO(mx, my)
+ ! swsaPO: Oceanic Salinity (in the oceanic mixed layer)
+ real, save :: swsaPO(mx, my)
+ ! tsswPO: Sea Water Freezing Temperature
+ real, save :: tsswPO(mx, my)
+ ! cwswPO: Sea Water Heat Capacity
+ real, save :: cwswPO(mx, my)
+ ! awmxPO: Max Fraction of Open Water
+ real, save :: awmxPO(mx, my)
+ ! uicePO : Sea-Ice Velocity
+ real, save :: uicePO(mx, my)
+ ! vicePO : Sea-Ice Velocity
+ real, save :: vicePO(mx, my)
+ ! ufraPO : Fraizil Velocity
+ real, save :: ufraPO(mx, my)
+ ! vfraPO : Fraizil Velocity
+ real, save :: vfraPO(mx, my)
+ ! hfraPO : Fraizil Thickness
+ real, save :: hfraPO(mx, my)
+ ! hicePO : Sea-Ice Thickness (Old Ice)
+ real, save :: hicePO(mx, my)
+ ! aicePO : Sea-Ice Fraction (Old Ice)
+ real, save :: aicePO(mx, my)
+ ! hiavPO : Sea-Ice Thickness (Average)
+ real, save :: hiavPO(mx, my)
+ ! vgriPO : Grease Ice Volume (New Ice)
+ real, save :: vgriPO(mx, my)
+endmodule mar_po
diff --git a/MAR/code_mar/mar_ra_mod.f90 b/MAR/code_mar/mar_ra_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7a54ff52dc90f5f6f353994622cfb258243d545a
--- /dev/null
+++ b/MAR/code_mar/mar_ra_mod.f90
@@ -0,0 +1,71 @@
+! mar_ra : mar radiative scheme
+! =============================
+module mar_ra
+ use mardim
+ implicit none
+ ! pktRAd: Radiation Divergence ==> Diabatic Heating
+ real, save :: pktRAd(mx, my, mz)
+ ! RAdsol: Surface Downward Solar Heat Flux
+ real, save :: RAdsol(mx, my)
+ ! RAd_ir: Surface Downward IR Heat Flux
+ real, save :: RAd_ir(mx, my)
+ ! RAdOLR: Outgoing Longwave Radiation
+ real, save :: RAdOLR(mx, my)
+ ! RAdOSR: Outgoing Shortwave Radiation
+ real, save :: RadOSR(mx, my)
+ ! RAfnSO: Net Shortwave Radiation
+ real, save, allocatable :: RAfnSO(:, :, :)
+ ! RAfnIR: Net Longwave Radiation
+ real, save, allocatable :: RAfnIR(:, :, :)
+ ! RAfncSO: Clearsky Net Shortwave Radiation
+ real, save, allocatable :: RAfncSO(:, :, :)
+ ! RAfncIR: Clearsky Net Longwave Radiation
+ real, save, allocatable :: RAfncIR(:, :, :)
+ ! tviRA: Radiating Surface Temperature
+ real, save :: tviRA(mx, my)
+ ! IRsoil: Soil upward IR
+ real, save, allocatable :: IRsoil(:, :, :)
+ ! RAcd_O, RAcdtO: Cloud Optical Depth [-]
+ real, save, allocatable :: RAcd_O(:, :, :)
+ real, save :: RAcdtO(mx, my)
+ ! RAer_O, RAertO: Aeros.Optical Depth [-]
+ real, save, allocatable :: RAer_O(:, :, :)
+ real, save :: RAertO(mx, my)
+ ! pmb_RA: Pressure (hPa)
+ real, save :: pmb_RA(mzir)
+ ! tairRA: Temperature (K)
+ real, save :: tairRA(mzir)
+ ! qvapRA: Specific Humidity (kg/kg)
+ real, save :: qvapRA(mzir)
+ ! cld_RA: Cloudiness at level k
+ real, save :: cld_RA(mzir)
+ ! qlwpRA: Cloud Liquid Water Path (level k)
+ real, save :: qlwpRA(mzir)
+ ! toptRA: Cloud Optical Depth (level k)
+ real, save :: toptRA(mzir)
+ ! wo3_RA: Ozone Content (cm STP)
+ real, save :: wo3_RA(mzir)
+ ! dwo3RA: Ozone Content (Divergence)
+ real, save :: dwo3RA(mzir)
+ ! htngRA: Radiative Heating (K/s)
+ real, save :: htngRA(mzir)
+
+contains
+
+ subroutine mar_ra_init()
+
+ use mardim, only: mx, my, mz,mzz
+ implicit none
+
+ allocate(RAfnSO(mx, my, mz))
+ allocate(RAfnIR(mx, my, mzz))
+ allocate(RAfncSO(mx, my, mz))
+ allocate(RAfncIR(mx, my, mzz))
+ allocate(IRsoil(mx, my, mw))
+ allocate(RAcd_O(mx, my, mz))
+ allocate(RAer_O(mx, my, mz))
+
+ endsubroutine mar_ra_init
+
+
+endmodule mar_ra
diff --git a/MAR/code_mar/mar_sl_mod.f90 b/MAR/code_mar/mar_sl_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fdf5fd3dcc7d294253efec8d4a80f44d16fa403b
--- /dev/null
+++ b/MAR/code_mar/mar_sl_mod.f90
@@ -0,0 +1,301 @@
+! mar_sl : mar surface air layers
+! ===============================
+module mar_sl
+ use mardim
+ implicit none
+ ! Ta2mSL : interpolated 2 meter air temperature
+ real, save, allocatable :: Ta2mSL(:, :, :)
+ ! TminSL : minimum 2 meter air temperature
+ real, save, allocatable :: TminSL(:, :, :)
+ ! TmaxSL : maximum 2 meter air temperature
+ real, save, allocatable :: TmaxSL(:, :, :)
+ ! Ta3mSL : interpolated 3 meter air temperature
+ real, save, allocatable :: Ta3mSL(:, :, :)
+ ! V03mSL : interpolated 3 meter wind speed
+ real, save, allocatable :: V03mSL(:, :, :)
+ ! V10mSL : interpolated 10 meter wind speed
+ real, save, allocatable :: V10mSL(:, :, :)
+ ! tairSL : extrapolation of the sounding tempature to the surface. (K)
+ real, save :: tairSL(mx, my)
+ ! dtagSL : Air-Surface Temperature Difference (K)
+ real, save :: dtagSL
+ ! tsrfSL : Surface Temperature (K)
+ real, save :: tsrfSL(mx, my, mw)
+ ! qvapSL : specific humidity close to the surface (kg/kg)
+ real, save :: qvapSL(mx, my)
+ ! isolSL : Surface Type : 1 -> open ocean
+ ! 2 -> glacier + ice sheet + snow
+ ! 3 -> sea ice (+ snow)
+ ! 4 -> soil (+ snow)
+ ! 5 -> soil + vegetation
+ integer, save :: isolSL(mx, my)
+ ! maskSL : Land--Sea Mask 0 -> Continent 1 -> Ocean
+ integer, save :: maskSL(mx, my)
+ ! sol_SL : Absorbed Solar Heat Flux (W/m2)
+ real, save :: sol_SL(mx, my)
+ ! firdSL : Downward IR Heat Flux (W/m2)
+ real, save :: firdSL(mx, my)
+ ! firmSL : Upward IR Heat Flux (W/m2)
+ real, save :: firmSL(mx, my)
+ ! hsenSL : Downward Sensible Heat Flux (W/m2)
+ real, save :: hsenSL(mx, my)
+ ! hlatSL : Evapora. Latent Heat Flux (W/m2)
+ real, save :: hlatSL(mx, my)
+ ! fmelSL : Melting Latent Heat Flux (W/m2)
+ real, save :: fmelSL(mx, my)
+ ! freeSL : Freezing Latent Heat Flux (W/m2)
+ real, save :: freeSL(mx, my)
+ ! hbalSL : Total Surface Heat Loss (W/m2)
+ real, save :: hbalSL(mx, my)
+ ! cld_SL: Total Cloudiness above the Surface
+ real, save :: cld_SL(mx, my)
+ real, save :: clduSL(mx, my)
+ real, save :: cldmSL(mx, my)
+ real, save :: clddSL(mx, my)
+ ! CldFRA: Cloud Fraction [-]
+ real, save, allocatable :: CldFRA(:, :, :)
+ ! alb0SL : Background Surface Albedo
+ real, save :: alb0SL(mx, my)
+ ! albeSL : Grid Mesh Surface Albedo
+ real, save :: albeSL(mx, my)
+ ! albsSL : Underlaying Soil Albedo
+ real, save :: albsSL(mx, my)
+ ! albxSL : Mosaic Surface Albedo
+ real, save, allocatable :: albxSL(:, :, :)
+ ! alb0SL_1: Background Surface Albedo for first spectral band [0.3-0.8um]
+ real, save, allocatable :: alb0SL_1(:, :)
+ ! alb0SL_2: Background Surface Albedo for second spectral band [0.8-1.5um]
+ real, save, allocatable :: alb0SL_2(:, :)
+ ! alb0SL_3: Background Surface Albedo for third spectral band [1.5-2.8um]
+ real, save, allocatable :: alb0SL_3(:, :)
+ ! tgirSL : Effective Surface Radiative Temperature
+ real, save, allocatable :: tgirSL(:, :)
+ ! eps0SL : Surface IR Emissivity
+ real, save, allocatable :: eps0SL(:, :)
+ ! nSLsrf : Number of Sectors in a Grid Box (m/s)
+ integer, save :: nSLsrf(mx, my)
+ integer, parameter :: ntavSL = 20
+ ! SLsrfl : Normalized Sector Area (m/s)
+ real, save :: SLsrfl(mx, my, mw)
+ ! SLzoro : Roughness Length for Momentum (Orography) (m/s)
+ real, save, allocatable :: SLzoro(:, :, :)
+ ! SL_z0 : Roughness Length for Momentum (m/s)
+ real, save, allocatable :: SL_z0(:, :, :)
+ real, save, allocatable :: SLn_z0(:, :, :, :)
+ ! SL_r0 : Roughness Length for Heat (m/s)
+ real, save, allocatable :: SL_r0(:, :, :)
+ real, save, allocatable :: SLn_b0(:, :, :, :)
+ real, save, allocatable :: SLn_r0(:, :, :, :)
+ ! SLlmo : Monin-Obukhov Length (Average) (m/s)
+ real, save, allocatable :: SLlmo(:, :)
+ ! SLlmol : Monin-Obukhov Length (m/s)
+ real, save, allocatable :: SLlmol(:, :, :)
+ ! SLuus : Friction Velocity (Average) (m/s)
+ real, save, allocatable :: SLuus(:, :)
+ ! SLuusl : Friction Velocity (m/s)
+ real, save, allocatable :: SLuusl(:, :, :)
+ ! duusSL : Correct. Friction Velocity (Average) (m2/s2)
+ real, save, allocatable :: duusSL(:, :)
+ ! SLuts : Surface Potential Temperature Turbulent Flux (Average) (K.m/s)
+ real, save, allocatable :: SLuts(:, :)
+ ! SLutsl : Surface Potential Temperature Turbulent Flux (K.m/s)
+ real, save, allocatable :: SLutsl(:, :, :)
+ ! SLdSdT : Sensible Turbulent Heat Flux T-Derivative (W/m2/K)
+ real, save, allocatable :: SLdSdT(:, :, :)
+ ! dutsSL : Correct. Potential Temperature Turbulent Flux (Average) (K.m/s)
+ real, save, allocatable :: dutsSL(:, :)
+ ! cutsSL : Correct. Potential Temperature Turbulent Flux (K.m/s)
+ real, save, allocatable :: cutsSL(:, :, :)
+ ! SLuqs : Surface Specific Humidity Turbulent Flux (Av.) (kg/kg.m/s)
+ real, save, allocatable :: SLuqs(:, :)
+ ! SLuqsl : Surface Specific Humidity Turbulent Flux (kg/kg.m/s)
+ real, save, allocatable :: SLuqsl(:, :, :)
+ ! SLdLdT : Latent Turbulent Heat Flux T-Derivative (W/m2/K)
+ real, save, allocatable :: SLdLdT(:, :, :)
+ ! SaltSL : Friction Velocity Saltation Threshold (m/s)
+ real, save, allocatable :: SaltSL(:, :)
+ ! SLussl : Surface Blowing Snow Turbulent Flux (kg/kg.m/s)
+ real, save, allocatable :: SLussl(:, :, :)
+ ! SLubsl : Surface Blowing Dust Turbulent Flux (kg/kg.m/s)
+ real, save, allocatable :: SLubsl(:, :, :)
+ ! virSL : Air Loading for SBL Parameterization
+ real, save, allocatable :: virSL(:, :)
+ ! fracSL : Fractional Time used in Blowing Snow Surface Flux Computation
+ real, save :: fracSL
+ ! u*, u*T*, u*s* Time Moving Averages
+ integer, parameter :: ntaver = 4 ! 9 in the old MAR version
+ real, save, allocatable :: u_0aSL(:, :, :, :)
+ real, save, allocatable :: uT0aSL(:, :, :, :)
+ real, save, allocatable :: us0aSL(:, :, :, :)
+ ! V, dT(a-s) Time Moving Averages
+ real, save, allocatable :: V_0aSL(:, :, :)
+ real, save, allocatable :: dT0aSL(:, :, :, :)
+ ! cdnSL : Square Root of Momentum Neutral Drag Coefficient (-)
+ real, save, allocatable :: cdnSL(:, :, :)
+ ! cdmSL : Contribution of Momentum to Drag Coefficient (-)
+ real, save, allocatable :: cdmSL(:, :, :)
+ ! cdhSL : Contribution of Heat to Drag Coefficient (-)
+ real, save, allocatable :: cdhSL(:, :, :)
+ ! zs_SL : Typical Sea Roughness Length (m)
+ real, save :: zs_SL
+ ! zn_SL : Typical Snow Roughness Length (m)
+ real, save :: zn_SL
+ ! zl_SL : Typical Land Roughness Length (m)
+ real, save :: zl_SL
+ ! u*, u*T*, u*s* Time Moving Averages
+ ! aeCdSL : Aerodynamic Conductance
+ real, save, allocatable :: aeCdSL(:, :)
+ ! Kv__SL : Equivalent Turbulent Diffusivity
+ real, save, allocatable :: Kv__SL(:, :)
+ ! pktaSL : SBCTurbulence Pot. Temp.
+ real, save, allocatable :: pktaSL(:, :)
+ ! ssvSL: Wind Speed Norm (m/s)
+ real, save, allocatable :: ssvSL(:, :, :)
+ ! ch0SL : Bulk Aerodynamic Coefficient Air/Surface Humidity Flux
+ real, save, allocatable :: ch0SL(:, :)
+ ! roseSL : Depletion of water vapor in the surface layer (kg/kg)
+ ! due to deposition of dew or rime on ground
+ real, save, allocatable :: roseSL(:, :)
+ ! raerSL :`Bulk' Stomatal Resistance (Thom & Oliver, 1977, p. 347)
+ real, save, allocatable :: raerSL(:, :)
+ ! rsurSL : Aerodynamic Resistance
+ real, save, allocatable :: rsurSL(:, :)
+ ! precSL : Rain
+ real, save, allocatable :: precSL(:, :)
+ integer, parameter :: nLimit = 10
+ ! WV__SL : Water Vapor Flux Limitor
+ real, save, allocatable :: WV__SL(:, :, :)
+ ! bsnoSL : cumulative snow erosion height (m)
+ real, save, allocatable :: bsnoSL(:, :)
+ ! snobSL : snow erosion height (m)
+ real, save, allocatable :: snobSL(:, :)
+ ! hsnoSL : cumulative snow accumulation height (m)
+ real, save, allocatable :: hsnoSL(:, :)
+ ! snohSL : snow precipitation height (m)
+ real, save, allocatable :: snohSL(:, :)
+ ! hmelSL : cumulative snowmelt height (m water equivalent)
+ real, save, allocatable :: hmelSL(:, :)
+ ! ro_SL0 : rhos (Initial Surface Density) (kg/m3)
+ real, save, allocatable :: ro_SL0(:, :)
+ ! ro_SL : rhos (Surface Density) (kg/m3)
+ real, save, allocatable :: ro_SL(:, :)
+ ! d1_SL : rhos * cs *(Depth diurnal Wave) (J/m2/K)
+ real, save, allocatable :: d1_SL(:, :)
+ ! cs2SL : Soil Temperature Variation Time Scale (s)
+ ! (usually 86400 s, i.e. diurnal cycle)
+ real, save :: cs2SL
+ ! t2SLtn, t2SLtd: time constants for t2_SL time integration
+ real, save :: t2SLtn
+ real, save :: t2SLtd
+ ! t2_SL : Soil Deep Layers Temperature (K)
+ real, save, allocatable :: t2_SL(:, :)
+ ! dtgSL : Soil Temperature Variation during time interval dt (K)
+ ! is renewed every 6 minutes
+ real, save, allocatable :: dtgSL(:, :, :)
+ logical, save :: qsolSL
+ ! hwatSL Rain Accumulation (m)
+ real, save, allocatable :: hwatSL(:, :)
+ real, save :: w20SL
+ ! wg_SL and w2_SL Adimensional Numbers measuring Soil Water Content
+ ! w2_SL Rain Accumulation over a large Soil Thickness
+ real, save, allocatable :: w2_SL(:, :)
+ ! wg_SL Rain Accumulation near the Surface
+ real, save, allocatable :: wg_SL(:, :)
+ real, save :: wg0SL
+ real, save :: wk0SL
+ real, save, allocatable :: wk_SL(:, :)
+ real, save :: wx0SL
+ real, save, allocatable :: wx_SL(:, :)
+ ! sst_SL : Sea Surface Temperature
+ real, save :: sst_SL
+ ! SL_wge : wind gust estimate
+ real, save, allocatable :: SL_wge(:, :)
+ ! SLlwge : lower bound of the bounding interval around the estimate
+ real, save, allocatable :: SLlwge(:, :)
+ ! SLuwge : upper bound of the bounding interval around the estimate
+ real, save, allocatable :: SLuwge(:, :)
+
+contains
+
+ subroutine mar_sl_init()
+
+ use mardim, only: mx, my, mw
+ implicit none
+
+ allocate(Ta2mSL(mx, my, mw))
+ allocate(TminSL(mx, my, mw))
+ allocate(TmaxSL(mx, my, mw))
+ allocate(Ta3mSL(mx, my, mw))
+ allocate(V03mSL(mx, my, mw))
+ allocate(V10mSL(mx, my, mw))
+ allocate(CldFRA(mx, my, mz))
+ allocate(albxSL(mx, my, mw))
+ allocate(alb0SL_1(mx, my))
+ allocate(alb0SL_2(mx, my))
+ allocate(alb0SL_3(mx, my))
+ allocate(tgirSL(mx, my))
+ allocate(eps0SL(mx, my))
+ allocate(SLzoro(mx, my, mw))
+ allocate(SL_z0(mx, my, mw))
+ allocate(SLn_z0(mx, my, mw, ntavSL))
+ allocate(SL_r0(mx, my, mw))
+ allocate(SLn_b0(mx, my, mw, ntavSL))
+ allocate(SLn_r0(mx, my, mw, ntavSL))
+ allocate(SLlmo(mx, my))
+ allocate(SLlmol(mx, my, mw))
+ allocate(SLuus(mx, my))
+ allocate(SLuusl(mx, my, mw))
+ allocate(duusSL(mx, my))
+ allocate(SLuts(mx, my))
+ allocate(SLutsl(mx, my, mw))
+ allocate(SLdSdT(mx, my, mw))
+ allocate(dutsSL(mx, my))
+ allocate(cutsSL(mx, my, mw))
+ allocate(SLuqs(mx, my))
+ allocate(SLuqsl(mx, my, mw))
+ allocate(SLdLdT(mx, my, mw))
+ allocate(SaltSL(mx, my))
+ allocate(SLussl(mx, my, mw))
+ allocate(SLubsl(mx, my, mw))
+ allocate(virSL(mx, my))
+ allocate(u_0aSL(mx, my, mw, ntaver))
+ allocate(uT0aSL(mx, my, mw, ntaver))
+ allocate(us0aSL(mx, my, mw, ntaver))
+ allocate(V_0aSL(mx, my, ntaver))
+ allocate(dT0aSL(mx, my, mw, ntaver))
+ allocate(cdnSL(mx, my, mw))
+ allocate(cdmSL(mx, my, mw))
+ allocate(cdhSL(mx, my, mw))
+ allocate(aeCdSL(mx, my))
+ allocate(Kv__SL(mx, my))
+ allocate(pktaSL(mx, my))
+ allocate(ssvSL(mx, my, mz))
+ allocate(ch0SL(mx, my))
+ allocate(roseSL(mx, my))
+ allocate(raerSL(mx, my))
+ allocate(rsurSL(mx, my))
+ allocate(precSL(mx, my))
+ allocate(WV__SL(mx, my, nLimit))
+ allocate(bsnoSL(mx, my))
+ allocate(snobSL(mx, my))
+ allocate(hsnoSL(mx, my))
+ allocate(snohSL(mx, my))
+ allocate(hmelSL(mx, my))
+ allocate(ro_SL0(mx, my))
+ allocate(ro_SL(mx, my))
+ allocate(d1_SL(mx, my))
+ allocate(t2_SL(mx, my))
+ allocate(dtgSL(mx, my, mw))
+ allocate(hwatSL(mx, my))
+ allocate(w2_SL(mx, my))
+ allocate(wg_SL(mx, my))
+ allocate(wk_SL(mx, my))
+ allocate(wx_SL(mx, my))
+ allocate(SL_wge(mx, my))
+ allocate(SLlwge(mx, my))
+ allocate(SLuwge(mx, my))
+
+ endsubroutine mar_sl_init
+
+
+endmodule mar_sl
diff --git a/MAR/code_mar/mar_sv_mod.f90 b/MAR/code_mar/mar_sv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1e22202ee12754c38608ae0b2905cb2051852f02
--- /dev/null
+++ b/MAR/code_mar/mar_sv_mod.f90
@@ -0,0 +1,7 @@
+module mar_sv
+ implicit none
+ integer, parameter :: klonv = 1
+ integer, parameter :: nsol = 6
+ integer, parameter :: nsno = 40
+ integer, parameter :: nb_wri = 10
+endmodule mar_sv
diff --git a/MAR/code_mar/mar_tc_mod.f90 b/MAR/code_mar/mar_tc_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bbb8e86b816aaeaf5361a8e948bef385dae0b152
--- /dev/null
+++ b/MAR/code_mar/mar_tc_mod.f90
@@ -0,0 +1,38 @@
+! mar_tc
+! ======
+module mar_tc
+ use mardim
+ implicit none
+ integer, parameter :: ntrac = 28
+ integer, parameter :: nfxTC = 1
+ integer, parameter :: kinTC = 59
+ integer, parameter :: nPhot = 5
+ integer, parameter :: nkWri = 4
+ logical, save :: ldepTC
+ logical, save :: locaTC
+ real(kind=8), save :: chTC(mx, ntrac)
+ real(kind=8), save :: fxTC(nfxTC)
+ real(kind=8), save :: qvTC(mx)
+ real(kind=8), save :: tairTC(mx)
+ real(kind=8), save :: suTC(mx, nPhot)
+ real(kind=8), save :: raTC(mx, kinTC)
+ real(kind=8), save :: cochTC(mx, ntrac, ntrac)
+ real, save :: qxTC(mx, my, mz, ntrac)
+ real, save :: qsTC(mx, my, ntrac)
+ real, save :: uqTC(mx, my, ntrac)
+ real, save :: ch0TC(ntrac, 4)
+ real, save :: dchTC(ntrac, 4)
+ real, save :: efacTC(mx, my)
+ real, save :: vdepTC(ntrac)
+ real, save :: hhTC(mx)
+ real :: dt_ODE, dt2ODE
+ integer, save :: ikTC(nkWri)
+ integer, save :: krouTC(mx, my)
+ integer, save :: nt_ODE
+ integer, save :: jt_ODE
+ character(len=9), save :: namTC(ntrac)
+ character(len=9), save :: fixTC
+ ! Unity : [Molec./cm3]
+ real, parameter :: Unity = 1.
+ real, parameter :: cminTC = 1.e-8
+endmodule mar_tc
diff --git a/MAR/code_mar/mar_te_mod.f90 b/MAR/code_mar/mar_te_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d801983d99d3e4867d5cb5cbeb8c9cc2c48d2c07
--- /dev/null
+++ b/MAR/code_mar/mar_te_mod.f90
@@ -0,0 +1,34 @@
+! mar_te : mar turbulent kinetic energy
+! =====================================
+module mar_te
+ use mardim
+ implicit none
+ logical, save :: ini_KA_TE
+ ! ect_TE(i,j,k): turbulent kinetic energy (i,j,k+1/2) (m2/s2)
+ real, save, allocatable :: ect_TE(:, :, :)
+ ! zi__TE(i,j) : Inversion Height (i,j) (m)
+ real, save, allocatable :: zi__TE(:, :)
+ ! eps_TE(i,j,k) : dissipation of T.K.E. (i,j,k+1/2) (m2/s3)
+ real, save, allocatable :: eps_TE(:, :, :)
+ ! edt_TE(i,j) : minimum dissipation time (i,j) (s)
+ real, save, allocatable :: edt_TE(:, :)
+ ! tranTE(i,j,k) : transport of T.K.E. (i,j,k+1/2) (m2/s3)
+ real, save, allocatable :: tranTE(:, :, :)
+
+contains
+
+ subroutine mar_te_init()
+
+ use mardim, only: mx, my, mz
+ implicit none
+
+ allocate(ect_TE(mx, my, mz))
+ allocate(zi__TE(mx, my))
+ allocate(eps_TE(mx, my, mz))
+ allocate(edt_TE(mx, my))
+ allocate(tranTE(mx, my, mz))
+
+ endsubroutine mar_te_init
+
+
+endmodule mar_te
diff --git a/MAR/code_mar/mar_tu_mod.f90 b/MAR/code_mar/mar_tu_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d05e12bfdc750f9f187369a521e969ed4e805858
--- /dev/null
+++ b/MAR/code_mar/mar_tu_mod.f90
@@ -0,0 +1,39 @@
+! mar_tu :
+! =========
+module mar_tu
+ use mardim
+ implicit none
+ ! TUkvm : Vertical Diffusion Coefficient (Momentum) [m2/s]
+ real, save, allocatable :: TUkvm(:, :, :)
+ ! TUkvh : Vertical Diffusion Coefficient (Heat) [m2/s]
+ real, save, allocatable :: TUkvh(:, :, :)
+ ! TUmin : Vertical Diffusion Coefficient (Minimum) [m2/s]
+ real, save :: TUmin(mz)
+ ! TU_Pra : Prandtl Number (TUkvm/TUkvh) [-]
+ real, save, allocatable :: TU_Pra(:, :, :)
+ ! TUkhx : Horizont.Diffusion Coefficient (x-direct.) [m2/s]
+ real, save, allocatable :: TUkhx(:, :, :)
+ real, save :: TUkhff
+ real, save :: TUkhmx
+ ! TUkhy : Horizont.Diffusion Coefficient (y-direct.) [m2/s]
+ real, save, allocatable :: TUkhy(:, :, :)
+ ! TUspon: Horizont.Diffusion Coefficient (Top Sponge)[m2/s]
+ real, save :: TUspon(mzabso)
+
+contains
+
+ subroutine mar_tu_init()
+
+ use mardim, only: mx, my, mz
+ implicit none
+
+ allocate(TUkvm(mx, my, mz))
+ allocate(TUkvh(mx, my, mz))
+ allocate(TU_Pra(mx, my, mz))
+ allocate(TUkhx(mx, my, mz))
+ allocate(TUkhy(mx, my, mz))
+
+ endsubroutine mar_tu_init
+
+
+endmodule mar_tu
diff --git a/MAR/code_mar/mar_tv_mod.f90 b/MAR/code_mar/mar_tv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..146ccebc353626d2ebccbcc7260d4eb74bbb5642
--- /dev/null
+++ b/MAR/code_mar/mar_tv_mod.f90
@@ -0,0 +1,78 @@
+! mar_tv : vegetation
+! ===================
+module mar_tv
+ use mardim
+ use mar_sv
+ implicit none
+ integer, parameter :: nvx = mw
+ integer, parameter :: llx = nsol + 1
+ integer, parameter :: iptx = 5
+ integer, parameter :: imx = mx
+ integer, parameter :: jmx = my
+ ! deptTV: Soil Level Depth
+ real, save :: deptTV(0:llx)
+ ! dep2TV: Soil Layer Depth
+ real, save :: dep2TV(0:llx)
+ ! slopTV: Surface Slope
+ real, save :: slopTV(mx, my)
+ ! AlbSTV: Dry Soil Albedo
+ real, save :: AlbSTV(mx, my)
+ ! alaiTV: Leaf Area Index
+ real, save, allocatable :: alaiTV(:, :, :)
+ ! glf_TV: Green Leaf Fraction
+ real, save, allocatable :: glf_TV(:, :, :)
+ ! CaWaTV: Canopy Intercepted Water Content
+ real, save, allocatable :: CaWaTV(:, :, :)
+ ! CaSnTV: Canopy Intercepted Snow Content
+ real, save, allocatable :: CaSnTV(:, :, :)
+ ! TvegTV: Skin Vegetation Temperature
+ real, save, allocatable :: TvegTV(:, :, :)
+ ! TgrdTV: Skin Soil Temperature
+ real, save, allocatable :: TgrdTV(:, :, :)
+ ! TsolTV: Layer Soil Temperature
+ real, save, allocatable :: TsolTV(:, :, :, :)
+ ! eta_TV: Soil Moisture Content
+ real, save, allocatable :: eta_TV(:, :, :, :)
+ ! psigTV: Soil Hydraulic Potential
+ real, save, allocatable :: psigTV(:, :, :)
+ ! psivTV: Vegetation Hydraulic Potential
+ real, save, allocatable :: psivTV(:, :, :)
+ ! evapTV: Time Integrated Evapotranspiration [mm w.e.]
+ real, save :: evapTV(imx, jmx)
+ ! runoTV: Time Integrated (Sub)surface Flow
+ real, save :: runoTV(imx, jmx)
+ ! draiTV: Time Integrated Drainage Flow
+ real, save :: draiTV(imx, jmx)
+ ! iWaFTV=0 ==> no Water Flux; iWaFTV=1 ==> free drainage
+ integer, save :: iWaFTV(imx, jmx)
+ ! ivegTV: Vegetation Type Index
+ integer, save :: ivegTV(imx, jmx, nvx)
+ ! isolTV: Soil Type Index
+ integer, save :: isolTV(imx, jmx)
+ ! ifraTV: Vegetation Class Coverage (3 Class, Last One is Open Water)
+ real, save :: ifraTV(imx, jmx, nvx)
+ ! IO Grid Indices
+ integer, save :: IOi_TV(iptx), IOj_TV(iptx)
+ integer, save :: itx, ivg
+
+contains
+
+ subroutine mar_tv_init()
+ implicit none
+
+ allocate(alaiTV(imx, jmx, nvx))
+ allocate(glf_TV(imx, jmx, nvx))
+ allocate(CaWaTV(imx, jmx, nvx))
+ allocate(CaSnTV(imx, jmx, nvx))
+ allocate(TvegTV(imx, jmx, nvx))
+ allocate(TgrdTV(imx, jmx, nvx))
+ allocate(TsolTV(imx, jmx, nvx, llx))
+ allocate(eta_TV(imx, jmx, nvx, llx))
+ allocate(psigTV(imx, jmx, nvx))
+ allocate(psivTV(imx, jmx, nvx))
+
+ endsubroutine mar_tv_init
+
+
+endmodule mar_tv
+
diff --git a/MAR/code_mar/mar_ub_mod.f90 b/MAR/code_mar/mar_ub_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..01fc31966c5762e0239bf6e61b0fd550c12dd9ee
--- /dev/null
+++ b/MAR/code_mar/mar_ub_mod.f90
@@ -0,0 +1,46 @@
+! mar_ub : include upper sponge [2-03-2004]
+! mar_ub save variables are used to follow Reference State in MAR upper sponge
+! Reference: ARPS 4.0 User's Guide, para 6.4.3 p.152
+! ==================================================
+module mar_ub
+ use mardim
+ implicit none
+ real, save :: Ray_UB(mzabso)
+ real, save, allocatable :: uairUB(:, :, :)
+ real, save, allocatable :: vairUB(:, :, :)
+ real, save, allocatable :: pktaUB(:, :, :)
+ real, save, allocatable :: ua1_UB(:, :, :)
+ real, save, allocatable :: va1_UB(:, :, :)
+ real, save, allocatable :: pkt1UB(:, :, :)
+ real, save, allocatable :: ua2_UB(:, :, :)
+ real, save, allocatable :: va2_UB(:, :, :)
+ real, save, allocatable :: pkt2UB(:, :, :)
+ integer, save :: iyr_UB
+ integer, save :: mma_UB
+ integer, save :: jda_UB
+ integer, save :: jhu_UB
+ integer, save :: jdh_UB
+ integer(kind=8), save :: tim1UB
+ integer(kind=8), save :: tim2UB
+
+contains
+
+ subroutine mar_ub_init()
+
+ use mardim, only: mx, my, mzabso
+ implicit none
+
+ allocate(uairUB(mx, my, mzabso))
+ allocate(vairUB(mx, my, mzabso))
+ allocate(pktaUB(mx, my, mzabso))
+ allocate(ua1_UB(mx, my, mzabso))
+ allocate(va1_UB(mx, my, mzabso))
+ allocate(pkt1UB(mx, my, mzabso))
+ allocate(ua2_UB(mx, my, mzabso))
+ allocate(va2_UB(mx, my, mzabso))
+ allocate(pkt2UB(mx, my, mzabso))
+
+
+ endsubroutine mar_ub_init
+
+endmodule mar_ub
diff --git a/MAR/code_mar/mar_vb_mod.f90 b/MAR/code_mar/mar_vb_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a26de4a51ca25349d6ec73e1bc6e660e1584a7a0
--- /dev/null
+++ b/MAR/code_mar/mar_vb_mod.f90
@@ -0,0 +1,22 @@
+! mar_vb : follow MAR Vegetation Fraction (13-05-2002)
+! ====================================================
+module mar_vb
+ use mardim
+ use mar_tv
+ implicit none
+ ! glf1VB: Vegetation Class Coverage / Time Step n (3 Class, Last One is Open Water)
+ real, save :: glf1VB(mx, my, nvx)
+ ! LAI1VB: Leaf Area Index / Time Step n
+ real, save :: LAI1VB(mx, my, nvx)
+ ! glf2VB: Vegetation Class Coverage / Time Step n+1 (3 Class, Last One is Open Water)
+ real, save :: glf2VB(mx, my, nvx)
+ ! LAI2VB: Leaf Area Index / Time Step n+1
+ real, save :: LAI2VB(mx, my, nvx)
+ integer, save :: iyr_VB
+ integer, save :: mma_VB
+ integer, save :: jda_VB
+ integer, save :: jhu_VB
+ integer, save :: jdh_VB
+ integer(kind=8), save :: tim1VB
+ integer(kind=8), save :: tim2VB
+endmodule mar_vb
diff --git a/MAR/code_mar/mar_wk_mod.f90 b/MAR/code_mar/mar_wk_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9e894c2fa252d9ab8f34b0600e0ebe2a4124c613
--- /dev/null
+++ b/MAR/code_mar/mar_wk_mod.f90
@@ -0,0 +1,64 @@
+! mar_wk : work variables
+! =======================
+! wkXXX variables define a work area in order to minimize memory requirements
+module mar_wk
+ use mardim
+ implicit none
+ real, save :: WKxyz1(mx, my, mz), WKxyz2(mx, my, mz), &
+ WKxyz3(mx, my, mz), WKxyz4(mx, my, mz), &
+ WKxyz5(mx, my, mzz), WKxyz6(mx, my, mzz), &
+ WKxyz7(mx, my, mzz), WKxyz8(mx, my, mzz)
+ real, save :: WRKxys(mx, my, mw)
+ real, save :: WKxy1(mx, my), WKxy2(mx, my), WKxy3(mx, my), &
+ WKxy4(mx, my), WKxy5(mx, my), WKxy6(mx, my), &
+ WKxy7(mx, my), WKxy8(mx, my), WKxy9(mx, my), &
+ WKxy0(mx, my)
+ real :: WTxy1(mx, my), WTxy2(mx, my), WTxy3(mx, my), &
+ WTxy4(mx, my), WTxy5(mx, my), WTxy6(mx, my), &
+ WTxy7(mx, my), WTxy8(mx, my), WTxy9(mx, my), &
+ WTxy0(mx, my)
+ real, save :: WKxza(mx, mz), WKxzb(mx, mz), WKxzc(mx, mz), &
+ WKxzd(mx, mz), WKxzx(mx, mz), &
+ WKxzp(mx, mz), WKxzq(mx, mz)
+
+ real, allocatable :: WPxyz1(:, :, :)
+ real, allocatable :: WPxyz2(:, :, :)
+ real, allocatable :: WPxyz3(:, :, :)
+ real, allocatable :: WPxyz4(:, :, :)
+ real, allocatable :: WPxyz5(:, :, :)
+ real, allocatable :: WPxyz6(:, :, :)
+ real, allocatable :: WPxyz7(:, :, :)
+ real, allocatable :: WPxyz8(:, :, :)
+
+ real, allocatable :: WTxyz1(:, :, :), WTxyz2(:, :, :), &
+ WTxyz3(:, :, :), WTxyz4(:, :, :), &
+ WTxyz5(:, :, :), WTxyz6(:, :, :), &
+ WTxyz7(:, :, :), WTxyz8(:, :, :)
+
+contains
+
+ subroutine mar_wk_init()
+
+ use mardim, only: mx, my, mz,mzz
+ implicit none
+
+ allocate(WPxyz1(mx, my, mz))
+ allocate(WPxyz2(mx, my, mz))
+ allocate(WPxyz3(mx, my, mz))
+ allocate(WPxyz4(mx, my, mz))
+ allocate(WPxyz5(mx, my, mzz))
+ allocate(WPxyz6(mx, my, mzz))
+ allocate(WPxyz7(mx, my, mzz))
+ allocate(WPxyz8(mx, my, mzz))
+ allocate(WTxyz1(mx, my, mz))
+ allocate(WTxyz2(mx, my, mz))
+ allocate(WTxyz3(mx, my, mz))
+ allocate(WTxyz4(mx, my, mz))
+ allocate(WTxyz5(mx, my, mzz))
+ allocate(WTxyz6(mx, my, mzz))
+ allocate(WTxyz7(mx, my, mzz))
+ allocate(WTxyz8(mx, my, mzz))
+
+ endsubroutine mar_wk_init
+
+endmodule mar_wk
diff --git a/MAR/code_mar/marcdp_mod.f90 b/MAR/code_mar/marcdp_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..45c862318fd4d547d59fa793b3fb90a0f87bce0e
--- /dev/null
+++ b/MAR/code_mar/marcdp_mod.f90
@@ -0,0 +1,34 @@
+#include "MAR_pp.def"
+! marcdp : Col de Porte specific Constants
+! ========================================
+module marcdp
+ implicit none
+ ! +--Col de Porte specific Constants
+ ! + ===============================
+ ! ColPrt : Col de Porte Switch
+#if(CP)
+ logical, parameter :: ColPrt = .true.
+#else
+ logical, parameter :: ColPrt = .false.
+#endif
+ ! +--Fractions of total solar irradiances in 3 spectral intervals
+ ! + ------------------------------------------------------------
+ ! 0.3--0.8micr.m 0.8--1.5micr.m 1.5--2.8micr.m
+ ! (see Eric Martin Sept. 1996, CROCUS, subroutine METEO)
+ ! Dr_1SN, Dr_2SN, Dr_3SN : Direct Radiation
+ real, parameter :: Dr_1SN = 0.59
+ real, parameter :: Dr_2SN = 0.31
+ real, parameter :: Dr_3SN = 0.10
+ ! Df_1SN, Df_2SN, Df_3SN : Diffuse Radiation, Clear Sky
+ real, parameter :: Df_1SN = 0.95
+ real, parameter :: Df_2SN = 0.05
+ real, parameter :: Df_3SN = 0.00
+ ! Dfc1SN, Dfc2SN, Dfc3SN : Diffuse Radiation, Cloudy Sky
+ real, parameter :: Dfc1SN = 0.66
+ real, parameter :: Dfc2SN = 0.27
+ real, parameter :: Dfc3SN = 0.07
+ real, save :: DirSol
+ real, save :: DifSol
+ real, save :: TotSol
+ real, save :: Clouds
+endmodule marcdp
diff --git a/MAR/code_mar/marctr_mod.f90 b/MAR/code_mar/marctr_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..83d70fac0dfecedda4c637829ceb9fa68cd06324
--- /dev/null
+++ b/MAR/code_mar/marctr_mod.f90
@@ -0,0 +1,67 @@
+module marctr
+ implicit none
+ ! reaVAR: input INI: Previous Dyn. Simulation (MAR, GCM)
+ logical, save :: reaVAR
+ ! reaLBC: Input LBC: Previous Dyn. Simulation (MAR, GCM)
+ logical, save :: reaLBC
+ ! safVAR: Full Output on Saving Files MARxxx.DAT
+ logical, save :: safVAR
+ logical, save :: sALONE
+ logical, save :: geoNST
+ ! conmas: Mass Conservartion Constraint Initial Switch
+ logical, save :: conmas
+ ! potvor: Potential Vorticity Conservation Constraint Initial Switch
+ logical, save :: potvor
+ ! hamfil: Initial Filtered Fields (Time, Hamming)
+ logical, save :: hamfil
+ ! brocam: Brown and Campana Time Scheme Switch
+ logical, save :: brocam
+ ! LFrBAK: Leap-Frog Backward Advection Scheme Switch
+ logical, save :: LFrBAK
+ logical, save :: openLB
+ logical, save :: sommlb
+ logical, save :: FirstC
+ ! turhor: Horizontal Diffusion (Smagorinsky) Switch
+ logical, save :: turhor
+ logical, save :: SBLitr
+ logical, save :: tur_25
+ ! convec: Convective Adjustment Switch
+ logical, save :: convec
+ ! MFLX_d: Convective Adjustment (deep) Switch
+ logical, save :: MFLX_d
+ ! MFLX_s: Convective Adjustment (shallow) Switch
+ logical, save :: MFLX_s
+ ! micphy: Cloud Microphysics Switch
+ logical, save :: micphy
+ ! fracld: Fractional Cloudiness Switch
+ logical, save :: fracld
+ ! chimod: Atmospheric Chemical Model Switch
+ logical, save :: chimod
+ ! physic: Atmospheric/Surface Physics Switch
+ logical, save :: physic
+ ! polmod: Interactive Polynya Switch
+ logical, save :: polmod
+ ! snomod: Interactive Snow Model Switch
+ logical, save :: snomod
+ logical, save :: BloMod
+ ! vegmod: Interactive SVAT Switch
+ logical, save :: vegmod
+ logical, save :: VSISVAT
+ ! no_vec: Scalar (NO Vectorization) Switch
+ logical, save :: no_vec
+ integer(kind=4),save :: itexpe
+ !integer(kind=8),save :: itexpe ! for run longer than 30 years
+ integer, save :: iterun, nterun, nbhour, itConv
+ integer, save :: iboucl, nboucl, nprint, npr_nc
+ integer, save :: maptyp
+ integer, save :: log_1D
+ real, save :: Robert
+ real, save :: rrmin, rrmax
+ real, save :: rxbase, rxfact
+ real, save :: fxlead
+ ! tMFLXd: d(time) between 2 deep convection CALL
+ real, save :: tMFLXd
+ ! aMFLXd, aMFLXs: adjustment times (deep, shallow)
+ real, save :: aMFLXd, aMFLXs
+ character(len=16), save :: fnam
+endmodule marctr
diff --git a/MAR/code_mar/mardim_mod.f90 b/MAR/code_mar/mardim_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..27f501d8518a78e115b021f1b09bba252b5d0669
--- /dev/null
+++ b/MAR/code_mar/mardim_mod.f90
@@ -0,0 +1,36 @@
+module mardim
+ implicit none
+ integer, parameter :: mx = 80
+ integer, parameter :: my = 140
+ integer, parameter :: ip11 = 2
+ integer, parameter :: jp11 = 2
+ integer, parameter :: mz = 25
+ ! mzir1 may be chosen much larger than mz,
+ ! if the model vertical domain covers a small part of the air column
+ integer, parameter :: mzir1 = mz + 1
+ integer, parameter :: mzir = mz + 2
+ integer, parameter :: mx1 = 79
+ integer, parameter :: mx2 = 78
+ integer, parameter :: my1 = 139
+ integer, parameter :: my2 = 138
+ integer, parameter :: myd2 = 1 + my / 2
+ integer, parameter :: mz1 = mz - 1
+ integer, parameter :: mzz = mz + 1
+ integer, parameter :: i_2 = mx - mx1 + 1
+ integer, parameter :: j_2 = my - my1 + 1
+ integer, parameter :: mzabso = 6
+ integer, parameter :: mzhyd = mzabso + 1
+ ! if #NV removed (NO vectorization) then klon = 1
+ integer, parameter :: klon = 1
+ integer, parameter :: klev = mz
+ integer, parameter :: kdlon = klon
+ integer, parameter :: kflev = klev
+ ! n6 et n7 determine a relaxation zonetowards lateral boundaries
+ ! (large scale values of the variables).
+ ! This zone extends over n6-1 points.
+ ! Davies (1976) propose 5 points (i.e. n6=6 and n7=7)
+ integer, parameter :: n6 = 6
+ integer, parameter :: n7 = 7
+ ! mw is the total number of mosaics
+ integer, parameter :: mw = 2
+endmodule mardim
diff --git a/MAR/code_mar/mardsv_mod.f90 b/MAR/code_mar/mardsv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..62107e994532348ad50c3d081b5165023cfc1e61
--- /dev/null
+++ b/MAR/code_mar/mardsv_mod.f90
@@ -0,0 +1,229 @@
+#include "MAR_pp.def"
+! +------------------------------------------------------------------------+
+! | MAR SISVAT_dat 20-07-2021 MAR |
+! | SubRoutine SISVAT_dat contains the constants of the |
+! | Soil/Ice Snow Vegetation Atmosphere Transfer Scheme |
+! +------------------------------------------------------------------------+
+module mardsv
+ use mar_sv
+ implicit none
+ ! +--SISVAT Global Variables
+ ! + =======================
+ ! INI_SV :Initialisation Switch
+ logical, save :: INI_SV = .false.
+ ! eps_21 : Arbitrary very small value
+ real, parameter :: eps_21 = 1.e-21
+ ! +--Snow
+ ! + ----
+ ! istdSV : Snow History
+ ! 1: faceted cristal
+ ! 2: liq.watr/no faceted cristal before
+ ! 3: liq.watr/ faceted cristal before
+ integer, parameter :: istdSV(5) = (/1, 2, 3, 4, 5/)
+ ! Cn_dSV : Snow Heat Capacity [J/kg/K]
+ ! Loth et al. 1993, JGR 98 D6 2.2.2 2e para p.10453
+ real, parameter :: Cn_dSV = 2105.
+ ! SMndSV : Minimum Thickness of new Layers [mmWE]
+ real, parameter :: SMndSV = 1.0
+ ! G1_dSV : Conversion 0/99-->0/1 Sphericity/Dendricity
+ real, parameter :: G1_dSV = 99.
+ ! DDcdSV, DFcdSV, DScdSV : Snow Grains Optical Diameter [1e-4m]
+ ! DDcdSV : Dendritic Crystals [0.0001 m]
+ real, parameter :: DDcdSV = 1.
+ ! DFcdSV : Young Faceted Crystals [0.0001 m]
+ real, parameter :: DFcdSV = 4.
+ ! Small Crystals [0.0001 m]
+ real, parameter :: DScdSV = 3.
+ ! ADSdSV : Snow Grains Actual Diameter [1e-4m]
+ real, parameter :: ADSdSV = 4.
+ ! So1dSV, So2dSV, So3dSV : Total Solar Irradiance Fractions [-]
+ ! Fractions of total Solar Irradiance in 3 spectral Intervals
+ ! (see Feagle and Businger 1981, Int.Geoph.Ser. 25, p.215-222)
+ ! So1dSV : 0.3--0.8mim Interval
+ real, parameter :: So1dSV = 0.6
+ ! So2dSV : 0.8--1.5mim Interval
+ real, parameter :: So2dSV = 0.3
+ ! So3dSV : 1.5--2.8mim Interval
+ real, parameter :: So3dSV = 0.1
+ ! initial values
+ ! real, parameter :: So1dSV = 0.606
+ ! real, parameter :: So2dSV = 0.301
+ ! real, parameter :: So3dSV = 0.093
+ ! Tuning ETH camp
+ !XF real, parameter :: So1dSV = 0.580
+ !XF real, parameter :: So2dSV = 0.320
+ !XF real, parameter :: So3dSV = 0.100
+ ! aI1dSV, aI2dSV, aI3dSV : Bare Ice Albedo [-]
+ ! aI1dSV : Minimum bare ICE albedo [-]
+ real, parameter :: aI1dSV = 0.50
+ ! aI2dSV : Maximum bare ICE albedo [-]
+ real, parameter :: aI2dSV = 0.55
+ ! aI3dSV : ICE lense albedo at roCdSV kg/m3 and and minimum pure snow albedo
+ real, parameter :: aI3dSV = 0.70
+ ! ws0dSV : Irreducible Water Saturation in Snow
+ ! ws0dSV = 0.07: Coleou et al., 1998, A.Gl
+ ! ws0dSV = 0.08-0.15 : Greuell & Konzelmann (199
+#if(AC)
+ real, parameter :: ws0dSV = 0.05
+#else
+ real, parameter :: ws0dSV = 0.07 ! Greenland
+#endif
+ ! roCdSV : Pore hole close-off density [kg/m3]
+ ! roCdSV = 800: Greuell & Konzelmann (1994), Glo
+ ! roCdSV = 830: Harper et al. (2012), Nature
+ real, parameter :: roCdSV = 830.
+ ! roSdSV : Max pure snow density [kg/m3]
+ real, parameter :: roSdSV = 450.
+ ! roBdSV : Max blowing snow density [kg/m3]
+ real, parameter :: roBdSV = 450.
+ ! ru_dSV : Surficial Water Scale Factor [kg/m2]
+ real, parameter :: ru_dSV = 50.
+ ! +--Ice
+ ! + ---
+ ! CdidSV : Conductivity of pure Ice [W/m/K]
+ real, parameter :: CdidSV = 2.1
+ ! +--Vegetation
+ ! + ----------
+ ! nvgt : number of vegetation classes
+ integer, parameter :: nvgt = 13
+ ! DH_dSV : Displacement Height [m]
+ real, parameter :: DH_dSV(0:nvgt) = (/ &
+ ! 0 NO VEGETATION
+ 0.00, &
+ ! 1 CROPS LOW | 2 CROPS MEDIUM | 3 CROPS HIGH
+ 0.07, 0.21, 0.70, &
+ ! 4 GRASS LOW | 5 GRASS MEDIUM | 6 GRASS HIGH
+ 0.07, 0.21, 0.70, &
+ ! 7 BROADLEAF LOW | 8 BROADLEAF MEDIUM | 9 BROADLEAF HIGH
+ 1.40, 5.60, 14.00, &
+ ! 10 NEEDLELEAF LOW | 11 NEEDLELEAF MEDIUM | 12 NEEDLELEAF HIGH
+ 1.40, 5.60, 14.00, &
+ ! 13 City
+ 21.00/)
+ ! Z0mdSV : Roughness Length for Momentum [m]
+ real, parameter :: Z0mdSV(0:nvgt) = (/ &
+ ! 0 NO VEGETATION
+ 0.01, &
+ ! 1 CROPS LOW | 2 CROPS MEDIUM | 3 CROPS HIGH
+ 0.01, 0.03, 0.10, &
+ ! 4 GRASS LOW | 5 GRASS MEDIUM | 6 GRASS HIGH
+ 0.01, 0.03, 0.10, &
+ ! 7 BROADLEAF LOW | 8 BROADLEAF MEDIUM | 9 BROADLEAF HIGH
+ 0.20, 0.80, 2.00, &
+ ! 10 NEEDLELEAF LOW | 11 NEEDLELEAF MEDIUM | 12 NEEDLELEAF HIGH
+ 0.20, 0.80, 2.00, &
+ ! 13 City
+ 3.00/)
+ ! StodSV : Minimum Stomatal Resistance [s/m]
+ real, parameter :: StodSV(0:nvgt) = (/ &
+ ! 0 NO VEGETATION
+ 5000., &
+ ! 1 CROPS LOW | 2 CROPS MEDIUM | 3 CROPS HIGH
+ 50., 50., 50., &
+ ! 4 GRASS LOW | 5 GRASS MEDIUM | 6 GRASS HIGH
+ 50., 50., 50., &
+ ! 7 BROADLEAF LOW | 8 BROADLEAF MEDIUM | 9 BROADLEAF HIGH
+ 10., 10., 10., &
+ ! 10 NEEDLELEAF LOW | 11 NEEDLELEAF MEDIUM | 12 NEEDLELEAF HIGH
+ 10., 10., 10., &
+ ! 13 City
+ 5000./)
+ ! PR_dSV : Internal Plant Resistance [s]
+ real, parameter :: PR_dSV(0:nvgt) = (/ &
+ ! 0 NO VEGETATION
+ 0.0, &
+ ! 1 CROPS LOW | 2 CROPS MEDIUM | 3 CROPS HIGH
+ 0.5e9, 0.5e9, 0.5e9, &
+ ! 4 GRASS LOW | 5 GRASS MEDIUM | 6 GRASS HIGH
+ 0.5e9, 0.5e9, 0.5e9, &
+ ! 7 BROADLEAF LOW | 8 BROADLEAF MEDIUM | 9 BROADLEAF HIGH
+ 1.0e9, 1.0e9, 1.0e9, &
+ ! 10 NEEDLELEAF LOW | 11 NEEDLELEAF MEDIUM | 12 NEEDLELEAF HIGH
+ 1.0e9, 1.0e9, 1.0e9, &
+ ! 13 City
+ 0.0/)
+ ! rbtdSV : Roots Fraction Beta Coefficient [-]
+ real, parameter :: rbtdSV(0:nvgt) = (/ &
+ ! 0 NO VEGETATION
+ 0.000, &
+ ! 1 CROPS LOW | 2 CROPS MEDIUM | 3 CROPS HIGH
+ 0.961, 0.961, 0.961, &
+ ! 4 GRASS LOW | 5 GRASS MEDIUM | 6 GRASS HIGH
+ 0.943, 0.964, 0.972, &
+ ! 7 BROADLEAF LOW | 8 BROADLEAF MEDIUM | 9 BROADLEAF HIGH
+ 0.968, 0.962, 0.962, &
+ ! 10 NEEDLELEAF LOW | 11 NEEDLELEAF MEDIUM | 12 NEEDLELEAF HIGH
+ 0.971, 0.976, 0.976, &
+ ! 13 City
+ 0.000/)
+ ! pscdSV : Critical Leaf Water Potential [m]
+ real, parameter :: pscdSV = 250.
+ ! StxdSV : maximum Stomatal Resistance [s/m]
+ real, parameter :: StxdSV = 5000.
+ ! LAIdSV : maximum LAI
+ real, parameter :: LAIdSV = 4.
+ ! +--Soil
+ ! + ----
+ ! rcwdSV : Density * Water Specific Heat
+ real, parameter :: rcwdSV = 4.180e+6
+ ! dz_dSV : Soil Vertical Discretization (Layer's Thickness)
+ real, save :: dz_dSV(-nsol:0)
+ ! zz_dSV : Soil Thickness
+ real, save :: zz_dSV
+ ! number of soil layers
+ integer, parameter :: nsot = 12
+ ! etadSV : Water Content at Saturation [m3/m3]
+ real, parameter :: etadSV(0:nsot) = (/ &
+ ! 0 WATER ! 1 SAND ! 2 LOAMY SAND
+ 1.000, 0.395, 0.410, &
+ ! 3 SANDY LOAM ! 4 SILT LOAM ! 5 LOAM
+ 0.435, 0.485, 0.451, &
+ ! 6 SANDY CLAY LOAM ! 7 SILTY CLAY LOAM ! 8 CLAY LOAM
+ 0.420, 0.477, 0.476, &
+ ! 9 SANDY CLAY ! 10 SILTY CLAY ! 11 CLAY very wet
+ 0.426, 0.492, 0.482, &
+ ! 12 ICE
+ 0.001/)
+ ! psidSV : Water Succion at Saturation [m]
+ real, parameter :: psidSV(0:nsot) = (/ &
+ ! 0 WATER ! 1 SAND ! 2 LOAMY SAND
+ 1.000, 0.121, 0.090, &
+ ! 3 SANDY LOAM ! 4 SILT LOAM ! 5 LOAM
+ 0.218, 0.786, 0.478, &
+ ! 6 SANDY CLAY LOAM ! 7 SILTY CLAY LOAM ! 8 CLAY LOAM
+ 0.299, 0.356, 0.630, &
+ ! 9 SANDY CLAY ! 10 SILTY CLAY ! 11 CLAY very wet
+ 0.153, 0.490, 0.405, &
+ ! 12 ICE
+ 0.001/)
+ ! Ks_dSV : Hydraulic Conductivity at Saturation [m/s]
+ real, parameter :: Ks_dSV(0:nsot) = (/ &
+ ! 0 WATER ! 1 SAND ! 2 LOAMY SAND
+ 0.0e00, 176.0e-8, 156.3e-8, &
+ ! 3 SANDY LOAM ! 4 SILT LOAM ! 5 LOAM
+ 34.1e-8, 7.2e-8, 7.0e-8, &
+ ! 6 SANDY CLAY LOAM ! 7 SILTY CLAY LOAM ! 8 CLAY LOAM
+ 6.3e-8, 1.7e-8, 2.5e-8, &
+ ! 9 SANDY CLAY ! 10 SILTY CLAY ! 11 CLAY very wet
+ 2.2e-8, 1.0e-8, 1.3e-8, &
+ ! 12 ICE
+ 0.0e00/)
+ ! bCHdSV : Clapp-Hornberger Coefficient b [-]
+ real, parameter :: bCHdSV(0:nsot) = (/ &
+ ! 0 WATER ! 1 SAND ! 2 LOAMY SAND
+ 1.00, 2.05, 2.38, &
+ ! 3 SANDY LOAM ! 4 SILT LOAM ! 5 LOAM
+ 2.90, 3.30, 3.39, &
+ ! 6 SANDY CLAY LOAM ! 7 SILTY CLAY LOAM ! 8 CLAY LOAM
+ 5.12, 5.75, 6.52, &
+ ! 9 SANDY CLAY ! 10 SILTY CLAY ! 11 CLAY very wet
+ 8.40, 8.40, 9.40, &
+ ! 12 ICE
+ 0.02/)
+ ! +--Water Bodies
+ ! + ------------
+ ! vK_dSV : Diffusivity in Water [m2/s]
+ real, parameter :: vK_dSV = 1000.
+ ! TSIdSV : Sea-Ice Fraction: SST Scale [K]
+ real, parameter :: TSIdSV = 0.50
+endmodule mardsv
diff --git a/MAR/code_mar/margau.f90 b/MAR/code_mar/margau.f90
new file mode 100644
index 0000000000000000000000000000000000000000..deac02a397617cd61aff972f5add66b050c4ba17
--- /dev/null
+++ b/MAR/code_mar/margau.f90
@@ -0,0 +1,149 @@
+subroutine MARgau_x(i1, i2, j1, j2, k1, k2)
+
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS 17-12-2000 MAR |
+ ! | subroutine MARgau_x performs Gaussian Elimination Algorithm along x |
+ ! | (e.g. Pielke (1984), pp.302--303) |
+ ! | (needed to solve the implicit scheme developped for filtering) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: i1,i2,j1,j2,k1,k2: i,j,k Loops Limits |
+ ! | ^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ integer i1, i2, j1, j2, k1, k2, ix
+
+ data ix/0/
+
+ ! +--Forward Sweep
+ ! + ==============
+
+ if(ix /= 1) then
+ do k = k1, k2
+ do j = j1, j2
+ WKxyz5(i1, j, k) = WKxyz2(i1, j, k)
+ WKxyz6(i1, j, k) = -WKxyz1(i1, j, k) / WKxyz5(i1, j, k)
+ enddo
+ enddo
+ do i = ip1(i1), i2
+ do k = k1, k2
+ do j = j1, j2
+ WKxyz5(i, j, k) = WKxyz3(i, j, k) * WKxyz6(i - 1, j, k) + WKxyz2(i, j, k)
+ WKxyz6(i, j, k) = -WKxyz1(i, j, k) / WKxyz5(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ do k = k1, k2
+ do j = j1, j2
+ WKxyz7(i1, j, k) = WKxyz4(i1, j, k) / WKxyz5(i1, j, k)
+ enddo
+ enddo
+
+ do i = ip1(i1), i2
+ do k = k1, k2
+ do j = j1, j2
+ WKxyz7(i, j, k) = (WKxyz4(i, j, k) - WKxyz3(i, j, k) * WKxyz7(i - 1, j, k)) &
+ / WKxyz5(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Backward Sweep
+ ! + ==============
+
+ do i = im1(i2), i1, -1
+ do k = k1, k2
+ do j = j1, j2
+ WKxyz7(i, j, k) = WKxyz6(i, j, k) * WKxyz7(i + 1, j, k) + WKxyz7(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ return
+endsubroutine MARgau_x
+
+subroutine MARgau_y(i1, i2, j1, j2, k1, k2)
+
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS 17-12-2000 MAR |
+ ! | subroutine MARgau_y performs Gaussian Elimination Algorithm along y |
+ ! | (e.g. Pielke (1984), pp.302--303) |
+ ! | (needed to solve the implicit scheme developped for filtering) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: i1,i2,j1,j2,k1,k2: i,j,k Loops Limits |
+ ! | ^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+ integer i1, i2, j1, j2, k1, k2, ix
+
+ data ix/0/
+
+ ! +--Forward Sweep
+ ! + ==============
+
+ if(ix /= 1) then
+ do k = k1, k2
+ do i = i1, i2
+ WKxyz5(i, j1, k) = WKxyz2(i, j1, k)
+ WKxyz6(i, j1, k) = -WKxyz1(i, j1, k) / WKxyz5(i, j1, k)
+ enddo
+ enddo
+ do j = jp1(j1), j2
+ do k = k1, k2
+ do i = i1, i2
+ WKxyz5(i, j, k) = WKxyz3(i, j, k) * WKxyz6(i, j - 1, k) + WKxyz2(i, j, k)
+ WKxyz6(i, j, k) = -WKxyz1(i, j, k) / WKxyz5(i, j, k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ do k = k1, k2
+ do i = i1, i2
+ WKxyz7(i, j1, k) = WKxyz4(i, j1, k) / WKxyz5(i, j1, k)
+ enddo
+ enddo
+
+ do j = jp1(j1), j2
+ do k = k1, k2
+ do i = i1, i2
+ WKxyz7(i, j, k) = (WKxyz4(i, j, k) - WKxyz3(i, j, k) * WKxyz7(i, j - 1, k)) &
+ / WKxyz5(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! +--Backward Sweep
+ ! + ==============
+
+ do j = jm1(j2), j1, -1
+ do k = k1, k2
+ do i = i1, i2
+ WKxyz7(i, j, k) = WKxyz6(i, j, k) * WKxyz7(i, j + 1, k) + WKxyz7(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ return
+endsubroutine MARgau_y
diff --git a/MAR/code_mar/margrd_mod.f90 b/MAR/code_mar/margrd_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..99c2d137240677d5334587487d86272a9b17719b
--- /dev/null
+++ b/MAR/code_mar/margrd_mod.f90
@@ -0,0 +1,165 @@
+! margrd: mar grid
+! ================
+module margrd
+ use mardim
+ implicit none
+ ! dt : Time Step for Slow Dynamics (s)
+ real, save :: dt
+ ! dt_Loc: Time Step (dummy) (s)
+ real, save :: dt_Loc
+ ! dtquil: Time Step for 1-D Initialisation (s)
+ real, save :: dtquil
+ ! tequil: Time Span for 1-D Initialisation (s)
+ real, save :: tequil
+ ! dtfast: Time Step for Fast Dynamics (s)
+ real, save :: dtfast
+ ! dtAdvH: Time Step for Tracer Advection (s)
+ real, save :: dtAdvH
+ ! dtDiff: Time Step for Subgrid Scale Processes (s)
+ real, save :: dtDiff
+ real, save :: dtPhys
+ real, save :: dtRadi
+ real, save :: dthyd
+ ! idt : Time Step for Slow Dynamics (s)
+ integer, save :: idt
+ integer, save :: jdt
+ ! ntFast: Nb Fast Dyn.Tim.Steps for one Mix Dyn.Tim.Step
+ integer, save :: ntFast
+ ! nt_Mix: Nb Mix Dyn.Tim.Steps for one Slow Dyn.Tim.Step
+ integer, save :: nt_Mix
+ ! ntAdvH: Nb Trac.Adv.Tim.Steps for one Slow Dyn.Tim.Step
+ integer, save :: ntAdvH
+ ! ntDiff: Nb Turbul. Tim.Steps for one Slow Dyn.Tim.Step
+ integer, save :: ntDiff
+ ! ntPhys: Nb Srf.Phys.Tim.Steps for one Slow Dyn.Tim.Step
+ integer, save :: ntPhys
+ ! ntRadi: Nb Rad.Phys.Tim.Steps for one Slow Dyn.Tim.Step
+ integer, save :: ntRadi
+ integer, save :: nthyd
+ ! itFast: No Fast Dyn.Tim.Step
+ integer, save :: itFast
+ ! it_Mix: No Mix Dyn.Tim.Step
+ integer, save :: it_Mix
+ ! jtAdvH: Nb Slow Dyn.Tim.Steps for one Trac.Adv.Tim.Step
+ integer, save :: jtAdvH
+ ! jtDiff: Nb Slow Dyn.Tim.Steps for one Turbul. Tim.Step
+ integer, save :: jtDiff
+ ! jtPhys: Nb Slow Dyn.Tim.Steps for one Srf.Phys.Tim.Step
+ integer, save :: jtPhys
+ ! jtRadi: Nb Slow Dyn.Tim.Steps for one Rad.Phys.Tim.Step
+ integer, save :: jtRadi
+ integer, save :: jtRadi2
+ ! kssMAR: Nb of simul. % Second
+ integer, save :: kssMAR
+ ! jdplus: Day Offset
+ integer, save :: jdplus
+ ! mmplus: Month Offset
+ integer, save :: mmplus
+ ! jdaMAR: Nb of simulated Days
+ integer(kind=8), save :: jdaMAR
+ ! jhaMAR: Nb of simulated Hours in Day jdaMAR+1
+ integer(kind=8), save :: jhaMAR
+ ! jmmMAR: Nb of simulated Minutes in Hour jhaMAR+1
+ integer(kind=8), save :: jmmMAR
+ ! jssMAR: Nb of simulated Seconds in Minute jmmMAR+1
+ integer(kind=8), save :: jssMAR
+ integer(kind=8), save :: jhaRUN
+ integer(kind=8), save :: dt_new
+ integer(kind=8), save :: dt_old
+ ! center: Pressure Spatial Scheme centered or not
+ logical, save :: center
+ ! tsplit: Advection Time Scheme splitted or not
+ logical, save :: tsplit
+ ! staggr: Vertical Grid staggered or not
+ logical, save :: staggr
+ ! nordps: Pressure Spatial Scheme Precision (-1 or 4)
+ integer, save :: nordps
+ ! norhyd: Advection H2O Spatial Scheme Precision (-1 or 4)
+ integer, save :: norhyd
+ ! nortra: Advection Trac.Spatial Scheme Precision (-1 or 4)
+ integer, save :: nortra
+ ! fac43 = 4.d0 / 3.d0 (used in 4th order horizontal difference scheme)
+ real, save :: fac43
+ ! rxy = 1.d-3/(mx*my)
+ real, save :: rxy
+ ! dx : horizontal grid size (x direction)
+ real, save :: dx
+ ! dx2 = 2 dx
+ real, save :: dx2
+ ! dtx = dt / dx
+ real, save :: dtx
+ ! dxinv = 1 / dx
+ real, save :: dxinv
+ ! dxinv2 = 1 / (2 dx)
+ real, save :: dxinv2
+ ! dx3 dy3 : distance between lon / lat
+ real, save :: dx3(mx, my), dy3(mx, my)
+ ! dxy3 = (dx3 + dy3) / 2.
+ real, save :: dxy3(mx, my)
+ ! dxinv3 = 1. / (2 dx3)
+ ! dyinv3 = 1. / (2 dy3)
+ real, save :: dxinv3(mx, my), dyinv3(mx, my)
+ ! mez : origin grid point number (x direction)
+ integer, save :: imez
+ integer, save :: m1, m2, m3, m4
+ ! im1,2 : max(i-1, 1), max(i-2, 1), etc...
+ ! ip1,2 : min(i+1,mx), min(i+2,mx), etc...
+ integer, save :: im1(mx), ip1(mx), im2(mx), ip2(mx)
+ integer, save :: im3(mx), ip3(mx), im4(mx), ip4(mx)
+ integer, save :: mmx, mmx1, mmx2, mmx3, mmx4, mmx5, mmx6
+ integer, save :: m0x1, m0x2, m0x3, m0x4, m0x5, m0x6
+ ! dy : horizontal grid size (y direction)
+ real, save :: dy
+ ! dy2 = 2 dy
+ real, save :: dy2
+ ! dty = dt / dy
+ real, save :: dty
+ ! dyinv = 1 / dy
+ real, save :: dyinv
+ ! dyinv2 = 2 / dy
+ real, save :: dyinv2
+ ! jmez : origin grid point number (y direction)
+ integer, save :: jmez
+ integer, save :: mn, mn1, mn2, mn3, mn4
+ ! jm1,2 : max(j-1, 1), max(j-2, 1), etc...
+ ! jp1,2 : min(j+1,my), min(j+2,my), etc...
+ integer, save :: jm1(my), jp1(my), jm2(my), jp2(my)
+ integer, save :: jm3(my), jp3(my), jm4(my), jp4(my)
+ integer, save :: mmy, mmy1, mmy2, mmy3, mmy4, mmy5, mmy6
+ integer, save :: m0y1, m0y2, m0y3, m0y4, m0y5, m0y6
+ integer, save :: mmz, mmz1, mmz2
+ integer, save :: km1(mz), kp1(mz), km2(mz)
+ ! THE VERTICAL DISCRETIZATION IS DEFINED in subroutine iniver and auxgri
+ ! sigma : independant variable sigma on sigma levels (k)
+ real, save :: sigma(mz)
+ ! dsig_1 : difference ds(k+1/2)
+ real, save :: dsig_1(0:mzz)
+ ! qsig_1 : 1 / [difference ds(k+1/2) X 2]
+ real, save :: qsig_1(0:mzz)
+ ! dsig_2 : difference ds(k+1/2) X 2
+ real, save :: dsig_2(mzz)
+ ! sigmid : independant variable sigma between levels (k-1/2)
+ real, save :: sigmid(mzz)
+ ! dsigm1 : difference ds(k)
+ real, save :: dsigm1(mz)
+ ! qsigm1 : 1 / [difference ds(k)]
+ real, save :: qsigm1(mz)
+ ! dsigm2 : difference ds(k) X 2
+ real, save :: dsigm2(mz)
+ ! qsigm2 : 1 / [difference ds(k) X 2]
+ real, save :: qsigm2(mz)
+ ! zsigma : height of sigma levels
+ real, save :: zsigma(mz)
+ real, save :: z__SBL
+ ! xxkm : distance to the x axis origin (km)
+ ! this is generally taken as the coast
+ ! when studying land-sea interactions
+ real, save :: xxkm(mx)
+ ! yykm : distance to the y axis origin (km)
+ real, save :: yykm(my)
+ real, save :: xxkm2(mx), yykm2(my)
+ ! area : area of each grid cell
+ real, save :: area(mx, my)
+ ! sh : surface height (m)
+ real, save :: sh(mx, my)
+endmodule margrd
diff --git a/MAR/code_mar/margxyz.f90 b/MAR/code_mar/margxyz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7ce98ed9b5d3f5e7e18254ab6e1ee864cc680e9a
--- /dev/null
+++ b/MAR/code_mar/margxyz.f90
@@ -0,0 +1,149 @@
+subroutine MARgz_1mx1my(k1, k2, jj, var3d_1, var3d_2, var3d_3, var3d_4, var3d_out)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS 08-09-2017 MAR |
+ ! | subroutine MARgz_1mx1my performs Gaussian Elimination along s-Dir. |
+ ! | (e.g. Pielke (1984), pp.302--303) |
+ ! | (needed to solve the implicit scheme developped for filtering) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: k1,k2: k Loops Limits |
+ ! | ^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+ use mar_wk
+ implicit none
+ ! input
+ integer, intent(in) :: k1, k2, jj
+ real, intent(in) :: var3d_1(mx, my, mz)
+ real, intent(in) :: var3d_2(mx, my, mz)
+ real, intent(in) :: var3d_3(mx, my, mz)
+ real, intent(in) :: var3d_4(mx, my, mz)
+ ! output
+ real, intent(out) :: var3d_out(mx, my, mz)
+ ! local
+ real :: var2d_tmp1(mx, mz)
+ real :: var2d_tmp2(mx, mz)
+ integer ii, kk
+
+ ! +--Forward Sweep
+ ! + ==============
+
+ ! do j=1,my
+ do ii = 1, mx
+ var2d_tmp1(ii, k1) = var3d_2(ii, jj, k1)
+ var2d_tmp2(ii, k1) = -var3d_1(ii, jj, k1) / var2d_tmp1(ii, k1)
+ enddo
+ ! end do
+ do kk = kp1(k1), k2
+ ! do j=1,my
+ do ii = 1, mx
+ var2d_tmp1(ii, kk) = var3d_3(ii, jj, kk) * var2d_tmp2(ii, kk - 1) &
+ + var3d_2(ii, jj, kk)
+ var2d_tmp2(ii, kk) = -var3d_1(ii, jj, kk) / var2d_tmp1(ii, kk)
+ enddo
+ ! end do
+ enddo
+ ! do j=1,my
+ do ii = 1, mx
+ var3d_out(ii, jj, k1) = var3d_4(ii, jj, k1) / var2d_tmp1(ii, k1)
+ enddo
+ ! end do
+ do kk = kp1(k1), k2
+ ! do j=1,my
+ do ii = 1, mx
+ var3d_out(ii, jj, kk) = (var3d_4(ii, jj, kk) - var3d_3(ii, jj, kk) &
+ * var3d_out(ii, jj, kk - 1)) / var2d_tmp1(ii, kk)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Backward Sweep
+ ! + ==============
+
+ do kk = km1(k2), k1, -1
+ ! do j=1,my
+ do ii = 1, mx
+ var3d_out(ii, jj, kk) = var2d_tmp2(ii, kk) * var3d_out(ii, jj, kk + 1) &
+ + var3d_out(ii, jj, kk)
+ enddo
+ ! end do
+ enddo
+
+ return
+endsubroutine MARgz_1mx1my
+
+subroutine MARgz_2mx1y1_mp(kk1, kk2, jj, var3d_1, var3d_2, var3d_3, var3d_4, var3d_out)
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS 03-07-2004 MAR |
+ ! | subroutine MARgz_2mx1y1 performs Gaussian Elimination along s-Dir. |
+ ! | (e.g. Pielke (1984), pp.302--303) |
+ ! | (needed to solve the implicit scheme developped for filtering) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: k1,k2: k Loops Limits |
+ ! | ^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+ implicit none
+ ! inputs
+ integer, intent(in) :: kk1, kk2, jj
+ real, intent(in) :: var3d_1(mx, my, mz)
+ real, intent(in) :: var3d_2(mx, my, mz)
+ real, intent(in) :: var3d_3(mx, my, mz)
+ real, intent(in) :: var3d_4(mx, my, mz)
+ ! outputs
+ real, intent(out) :: var3d_out(mx, my, mz)
+ ! local
+ real :: var2d_tmp1(mx, mz)
+ real :: var2d_tmp2(mx, mz)
+ integer :: ii, kk
+
+ ! +--Forward Sweep
+ ! + ==============
+
+ ! do jj=jjp11,my1
+ do ii = ip11, mx1
+ var2d_tmp1(ii, kk1) = var3d_2(ii, jj, kk1)
+ var2d_tmp2(ii, kk1) = -var3d_1(ii, jj, kk1) / var2d_tmp1(ii, kk1)
+ enddo
+ ! end do
+ do kk = kp1(kk1), kk2
+ ! do jj=jjp11,my1
+ do ii = ip11, mx1
+ var2d_tmp1(ii, kk) = var3d_3(ii, jj, kk) * var2d_tmp2(ii, kk - 1) + var3d_2(ii, jj, kk)
+ var2d_tmp2(ii, kk) = -var3d_1(ii, jj, kk) / var2d_tmp1(ii, kk)
+ enddo
+ ! end do
+ enddo
+ ! do jj=jjp11,my1
+ do ii = ip11, mx1
+ var3d_out(ii, jj, kk1) = var3d_4(ii, jj, kk1) / var2d_tmp1(ii, kk1)
+ enddo
+ ! end do
+ do kk = kp1(kk1), kk2
+ ! do jj=jjp11,my1
+ do ii = ip11, mx1
+ var3d_out(ii, jj, kk) = (var3d_4(ii, jj, kk) - &
+ var3d_3(ii, jj, kk) * var3d_out(ii, jj, kk - 1)) / var2d_tmp1(ii, kk)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Backward Sweep
+ ! + ==============
+ do kk = km1(kk2), kk1, -1
+ ! do jj=jjp11,my1
+ do ii = ip11, mx1
+ var3d_out(ii, jj, kk) = var2d_tmp2(ii, kk) * var3d_out(ii, jj, kk + 1) + var3d_out(ii, jj, kk)
+ enddo
+ enddo
+ ! end do
+
+ return
+endsubroutine MARgz_2mx1y1_mp
diff --git a/MAR/code_mar/mariso_init.f90 b/MAR/code_mar/mariso_init.f90
new file mode 100644
index 0000000000000000000000000000000000000000..918612175c17aca6a104a52993a6478289fb7175
--- /dev/null
+++ b/MAR/code_mar/mariso_init.f90
@@ -0,0 +1,205 @@
+! Created by Cécile Agosta on 04/03/2021.
+! initialization routines for mariso
+
+subroutine mariso_init_sno(iso_init_type, rosSNo, wasSNo, SWaSNo, rosSNo_iso, wasSNo_iso, SWaSNo_iso)
+ ! isotopic initialization of sivat snowpack
+ ! iso_init_type = 0 : R = Rdefault
+ ! iso_init_type = 1 : R from observed delta
+ use mardim, only: mx, my, mz
+ use marssn, only: nsx
+ use mar_sv, only: nsno
+ use mariso, only: niso, Rdefault
+ implicit none
+ ! inputs
+ integer, intent(in) :: iso_init_type
+ real, intent(in) :: rosSNo(mx, my, nsx, nsno)
+ real, intent(in) :: wasSNo(mx, my, nsx, nsno)
+ real, intent(in) :: SWaSNo(mx, my, nsx)
+ ! outputs
+ real, intent(out) :: rosSNo_iso(niso, mx, my, nsx, nsno)
+ real, intent(out) :: wasSNo_iso(niso, mx, my, nsx, nsno)
+ real, intent(out) :: SWaSNo_iso(niso, mx, my, nsx)
+ ! local
+ integer wiso, i, j, k, n
+
+ ! isotopic initialization of sivat snowpack
+ if(iso_init_type == 0) then
+ ! iso_init_type = 0 : R = Rdefault
+ ! ================================
+ do n = 1, nsno
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ rosSNo_iso(wiso, i, j, k, n) = Rdefault(wiso) * rosSNo(i, j, k, n)
+ wasSNo_iso(wiso, i, j, k, n) = Rdefault(wiso) * wasSNo(i, j, k, n)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ SWaSNo_iso(wiso, i, j, k) = Rdefault(wiso) * SWaSNo(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ else if(iso_init_type == 1) then
+ ! TODO : add realistic initialization
+ ! iso_init_type = 1 : R from observed delta
+ ! =========================================
+ ! rosSNo_iso : Snow Volumic Mass kg/m3][
+ ! delta in per mil as a function of temperature
+ ! for Antarctica : Masson-Delmotte et al. 2008 https://dx.doi.org/10.1175/2007jcli2139.1 (Fig. 6)
+ ! delta_iso(iso18) =
+ ! delta_iso(isoD) =
+ ! R_iso(iso) = delta_iso(iso)
+ ! rosSNo_iso(i, j, n, k, iso) = R_iso(iso) * rosSNo(i, j, n, k)
+ else
+ write(6, *) "mariso ERROR: iso_init_type must be 0 or 1"
+ stop
+ endif
+
+endsubroutine mariso_init_sno
+
+subroutine mariso_init_tv(iso_init_type, eta_TV, eta_TV_iso)
+ ! isotopic initialization of sivat soil
+ ! iso_init_type = 0 : R = Rdefault
+ ! iso_init_type = 1 : R from observed delta
+ use mar_tv, only: imx, jmx, nvx, llx
+ use mariso, only: niso, Rdefault
+ implicit none
+ ! inputs
+ integer, intent(in) :: iso_init_type
+ real, intent(in) :: eta_TV(imx, jmx, nvx, llx)
+ ! outputs
+ real, intent(out) :: eta_TV_iso(niso, imx, jmx, nvx, llx)
+ ! local
+ integer wiso, i, j, k, n
+
+ ! isotopic initialization of sivat snowpack
+ if(iso_init_type == 0) then
+ ! iso_init_type = 0 : R = Rdefault
+ ! ================================
+ do n = 1, llx
+ do k = 1, nvx
+ do j = 1, jmx
+ do i = 1, imx
+ do wiso = 1, niso
+ eta_TV_iso(wiso, i, j, k, n) = Rdefault(wiso) * eta_TV(i, j, k, n)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ else if(iso_init_type == 1) then
+ ! TODO : add realistic initialization
+ ! iso_init_type = 1 : R from observed delta
+ ! =========================================
+ ! rosSNo_iso : Snow Volumic Mass kg/m3][
+ ! delta in per mil as a function of temperature
+ ! for Antarctica : Masson-Delmotte et al. 2008 https://dx.doi.org/10.1175/2007jcli2139.1 (Fig. 6)
+ ! delta_iso(iso18) =
+ ! delta_iso(isoD) =
+ ! R_iso(iso) = delta_iso(iso)
+ ! rosSNo_iso(i, j, n, k, iso) = R_iso(iso) * rosSNo(i, j, n, k)
+ else
+ write(6, *) "mariso ERROR: iso_init_type must be 0 or 1"
+ stop
+ endif
+
+endsubroutine mariso_init_tv
+
+subroutine mariso_init_sl(iso_init_type, qvapSL, qvapSL_iso)
+ ! isotopic initialization of sivat soil
+ ! iso_init_type = 0 : R = Rdefault
+ ! iso_init_type = 1 : R from observed delta
+ use mardim, only: mx, my
+ use mariso, only: niso, Rdefault
+ implicit none
+ ! inputs
+ integer, intent(in) :: iso_init_type
+ real, intent(in) :: qvapSL(mx, my)
+ ! outputs
+ real, intent(out) :: qvapSL_iso(niso, mx, my)
+ ! local
+ integer wiso, i, j
+
+ ! isotopic initialization of sivat snowpack
+ if(iso_init_type == 0) then
+ ! iso_init_type = 0 : R = Rdefault
+ ! ================================
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qvapSL_iso(wiso, i, j) = Rdefault(wiso) * qvapSL(i, j)
+ enddo
+ enddo
+ enddo
+ else if(iso_init_type == 1) then
+ ! TODO : add realistic initialization
+ ! iso_init_type = 1 : R from observed delta
+ ! =========================================
+ ! rosSNo_iso : Snow Volumic Mass kg/m3][
+ ! delta in per mil as a function of temperature
+ ! for Antarctica : Masson-Delmotte et al. 2008 https://dx.doi.org/10.1175/2007jcli2139.1 (Fig. 6)
+ ! delta_iso(iso18) =
+ ! delta_iso(isoD) =
+ ! R_iso(iso) = delta_iso(iso)
+ ! rosSNo_iso(i, j, n, k, iso) = R_iso(iso) * rosSNo(i, j, n, k)
+ else
+ write(6, *) "mariso ERROR: iso_init_type must be 0 or 1"
+ stop
+ endif
+
+endsubroutine mariso_init_sl
+
+subroutine mariso_init_dy(iso_init_type, qvDY, qvDY_iso)
+ ! isotopic initialization of sivat soil
+ ! iso_init_type = 0 : R = Rdefault
+ ! iso_init_type = 1 : R from observed delta
+ use mardim, only: mx, my, mz
+ use mariso, only: niso, Rdefault
+ implicit none
+ ! inputs
+ integer, intent(in) :: iso_init_type
+ real, intent(in) :: qvDY(mx, my, mz)
+ ! outputs
+ real, intent(out) :: qvDY_iso(niso, mx, my, mz)
+ ! local
+ integer wiso, i, j, k
+
+ ! isotopic initialization of sivat snowpack
+ if(iso_init_type == 0) then
+ ! iso_init_type = 0 : R = Rdefault
+ ! ================================
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ do wiso = 1, niso
+ qvDY_iso(wiso, i, j, k) = Rdefault(wiso) * qvDY(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+ else if(iso_init_type == 1) then
+ ! TODO : add realistic initialization
+ ! iso_init_type = 1 : R from observed delta
+ ! =========================================
+ ! rosSNo_iso : Snow Volumic Mass kg/m3][
+ ! delta in per mil as a function of temperature
+ ! for Antarctica : Masson-Delmotte et al. 2008 https://dx.doi.org/10.1175/2007jcli2139.1 (Fig. 6)
+ ! delta_iso(iso18) =
+ ! delta_iso(isoD) =
+ ! R_iso(iso) = delta_iso(iso)
+ ! rosSNo_iso(i, j, n, k, iso) = R_iso(iso) * rosSNo(i, j, n, k)
+ else
+ write(6, *) "mariso ERROR: iso_init_type must be 0 or 1"
+ stop
+ endif
+
+endsubroutine mariso_init_dy
diff --git a/MAR/code_mar/mariso_io.f90 b/MAR/code_mar/mariso_io.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9784aef116131a6c4a0e25458b41cf2bf2d7a351
--- /dev/null
+++ b/MAR/code_mar/mariso_io.f90
@@ -0,0 +1,278 @@
+subroutine mariso_create_file
+ ! create a netcdf and fill it will isotopic variables
+ use mardim, only: mx, my, mz
+ use margrd, only: xxkm, yykm, sigma
+ use mariso, only: niso, lab_iso
+ use libUN_mod
+ implicit none
+
+ ! local
+ character * 100 fileout
+ logical file_exists
+ ! ndim : number of defined dimensions (without time)
+ integer, parameter :: ndim = 3
+ ! dim_lenght : length of each dimension
+ integer dim_lenght(0:ndim)
+ ! dim_lmax : maximum length for all dims: recorded Time Steps
+ ! and also maximum of spatial grid points for each direction.
+ integer, parameter :: dim_lmax = 2000
+ ! Llnam, Lnam, Luni : Length of char strings
+ integer, parameter :: Lnam = 13
+ integer, parameter :: Luni = 30
+ integer, parameter :: Llnam = 50
+ ! dim_name : name of each dimension
+ character*(Lnam) :: dim_name(0:ndim)
+ ! dim_units : units of each dimension
+ character*(Luni) :: dim_units(0:ndim)
+ ! dim_values : values of dimension vectors
+ real :: dim_values(dim_lmax, 0:ndim)
+ ! nvar_max : Maximum Number of Variables
+ integer, parameter :: nvar_max = 36
+ ! nvar : total number of variables writen in the NetCDF file
+ integer :: nvar
+ ! var_name : variable name
+ character*(Lnam) :: var_name(nvar_max)
+ ! var_dimnames : dimension names of the variable
+ character*(Lnam) :: var_dimnames(4, nvar_max)
+ ! var_units : variable unit
+ character*(Luni) :: var_units(nvar_max)
+ ! var_longname : variable long name
+ character*(Llnam) :: var_longname(nvar_max)
+ ! NattNC_ice : number of real attributes given to all variables
+ integer, parameter :: NattNC_ice = 1
+ ! att_name : name of attribute
+ character*12, parameter :: att_name(1) = (/'actual_range'/)
+ ! att_ndim : "actual_range" is (min, max) of all data for each variable
+ integer, parameter :: att_ndim(1) = (/2/)
+
+ integer i, j, k, wiso, file_id
+
+ fileout = 'ISO_check.nc'
+
+ ! initialisation
+ ! ==============
+ file_id = -1 ! NetCDF File is not open
+
+ ! define dimensions
+ ! =================
+ ! time
+ dim_lenght(0) = 0
+ dim_name(0) = 'time'
+ dim_units(0) = 'number of increment since start of run'
+ ! x dimension
+ dim_lenght(1) = mx
+ dim_name(1) = 'x'
+ dim_units(1) = 'km'
+ do i = 1, mx
+ dim_values(i, 1) = xxkm(i)
+ enddo
+ ! y dimension
+ dim_lenght(2) = my
+ dim_name(2) = 'y'
+ dim_units(2) = 'km'
+ do j = 1, my
+ dim_values(j, 2) = yykm(j)
+ enddo
+ ! z dimension
+ dim_lenght(3) = mz
+ dim_name(3) = 'sigma'
+ dim_units(3) = '-'
+ do k = 1, mz
+ dim_values(k, 3) = sigma(k)
+ enddo
+
+ ! define variables
+ ! ================
+ nvar = 0
+ ! qvDY
+ nvar = nvar + 1
+ var_name(nvar) = 'qvDY'
+ var_longname(nvar) = 'specific humidity'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'qvDY_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' specific humidity'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ enddo
+ ! qiHY
+ nvar = nvar + 1
+ var_name(nvar) = 'qiHY'
+ var_longname(nvar) = 'cloud ice'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'qiHY_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' cloud ice'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ enddo
+ ! qsHY
+ nvar = nvar + 1
+ var_name(nvar) = 'qsHY'
+ var_longname(nvar) = 'precipitation ice'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'qsHY_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' precipitation ice'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ enddo
+ ! qwHY
+ nvar = nvar + 1
+ var_name(nvar) = 'qwHY'
+ var_longname(nvar) = 'cloud liquid'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'qwHY_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' cloud liquid'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ enddo
+ ! qrHY
+ nvar = nvar + 1
+ var_name(nvar) = 'qrHY'
+ var_longname(nvar) = 'precipitation liquid'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'qrHY_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' precipitation liquid'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = 'kg kg-1'
+ enddo
+ ! qvapSL
+ nvar = nvar + 1
+ var_name(nvar) = 'qvapSL'
+ var_longname(nvar) = 'surface specific humidity'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', '-', 'time']
+ var_units(nvar) = 'kg kg-1'
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'qvapSL_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' surface specific humidity'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', '-', 'time']
+ var_units(nvar) = 'kg kg-1'
+ enddo
+ ! tmp1 var
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'tmp1_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' tmp1'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = '-'
+ enddo
+ ! tmp2 var
+ do wiso = 1, niso
+ nvar = nvar + 1
+ var_name(nvar) = 'tmp2_'//lab_iso(wiso)
+ var_longname(nvar) = lab_iso(wiso)//' tmp2'
+ var_dimnames(:, nvar) = [character(len=nvar_max) :: 'x', 'y', 'sigma', 'time']
+ var_units(nvar) = '-'
+ enddo
+
+ call UNscreate(fileout, 'output file to check water isotopes', &
+ ndim, dim_lenght, dim_lmax, dim_name, dim_units, dim_values, &
+ nvar_max, nvar, var_name, var_dimnames, var_units, var_longname, &
+ 1, att_name, att_ndim, file_id)
+
+ call UNclose(file_id)
+
+endsubroutine mariso_create_file
+
+subroutine mariso_write_file(iso_time, iso_label)
+ use mardim, only: mx, my, mz
+ use mar_dy, only: qvDY
+ use mar_hy, only: qiHY, qsHY, qwHY, qrHY
+ use mar_sl, only: qvapSL
+ use mariso, only: niso, lab_iso, qvDY_iso, qvapSL_iso, qiHY_iso, qsHY_iso, qwHY_iso, qrHY_iso
+ use libUN_mod
+ implicit none
+ ! iso_label : label of the increment
+ character*10, intent(in) :: iso_label
+ ! iso_time : number of the increment
+ integer, intent(in) :: iso_time
+ ! local
+ integer file_id, wiso
+
+ ! open file
+ call UNwopen('ISO_check.nc', file_id)
+ ! write time increment
+ call UNwrite(file_id, 'time', iso_time, 1, 1, 1, iso_time)
+ ! write isotopic variables
+ ! qvDY
+ call UNwrite(file_id, 'qvDY', iso_time, mx, my, mz, qvDY)
+ do wiso = 1, niso
+ call UNwrite(file_id, 'qvDY_'//lab_iso(wiso), iso_time, mx, my, mz, qvDY_iso(wiso, :, :, :))
+ enddo
+ ! qiHY
+ call UNwrite(file_id, 'qiHY', iso_time, mx, my, mz, qiHY)
+ do wiso = 1, niso
+ call UNwrite(file_id, 'qiHY_'//lab_iso(wiso), iso_time, mx, my, mz, qiHY_iso(wiso, :, :, :))
+ enddo
+ ! qsHY
+ call UNwrite(file_id, 'qsHY', iso_time, mx, my, mz, qsHY)
+ do wiso = 1, niso
+ call UNwrite(file_id, 'qsHY_'//lab_iso(wiso), iso_time, mx, my, mz, qsHY_iso(wiso, :, :, :))
+ enddo
+ ! qwHY
+ call UNwrite(file_id, 'qwHY', iso_time, mx, my, mz, qwHY)
+ do wiso = 1, niso
+ call UNwrite(file_id, 'qwHY_'//lab_iso(wiso), iso_time, mx, my, mz, qwHY_iso(wiso, :, :, :))
+ enddo
+ ! qrHY
+ call UNwrite(file_id, 'qrHY', iso_time, mx, my, mz, qrHY)
+ do wiso = 1, niso
+ call UNwrite(file_id, 'qrHY_'//lab_iso(wiso), iso_time, mx, my, mz, qrHY_iso(wiso, :, :, :))
+ enddo
+ ! qvapSL
+ call UNwrite(file_id, 'qvapSL', iso_time, mx, my, 1, qvapSL)
+ do wiso = 1, niso
+ call UNwrite(file_id, 'qvapSL_'//lab_iso(wiso), iso_time, mx, my, 1, qvapSL_iso(wiso, :, :))
+ enddo
+ ! close file
+ call UNclose(file_id)
+
+ ! write increment and label
+ open(unit=222, file='iso_label.txt', action='write', position='append')
+ write(222, '(i10, A4, A10)') iso_time, ' :: ', iso_label
+ close(unit=222)
+
+endsubroutine mariso_write_file
+
+subroutine mariso_write_var3d(var3d_iso, var_name, iso_time)
+ use mardim, only: mx, my, mz
+ use mar_dy, only: qvDY
+ use mar_hy, only: qiHY, qsHY, qwHY, qrHY
+ use mar_sl, only: qvapSL
+ use mariso, only: niso, lab_iso
+ use libUN_mod
+ implicit none
+ ! var3d : 3d variable to be writen
+ real, intent(in) :: var3d_iso(niso, mx, my, mz)
+ ! var_name : variable name
+ character*4, intent(in) :: var_name
+ ! iso_time : number of the increment
+ integer, intent(in) :: iso_time
+ ! local
+ integer wiso, file_id
+
+ ! open file
+ call UNwopen('ISO_check.nc', file_id)
+ ! write time increment
+ call UNwrite(file_id, 'time', iso_time, 1, 1, 1, iso_time)
+ ! write 3d variables
+ do wiso = 1, niso
+ call UNwrite(file_id, var_name//'_'//lab_iso(wiso), iso_time, mx, my, mz, var3d_iso(wiso, :, :, :))
+ enddo
+ ! close file
+ call UNclose(file_id)
+endsubroutine mariso_write_var3d
diff --git a/MAR/code_mar/mariso_mod.f90 b/MAR/code_mar/mariso_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1c300fcfc04d0fed4f5b4d63d5153b713bddb9b3
--- /dev/null
+++ b/MAR/code_mar/mariso_mod.f90
@@ -0,0 +1,434 @@
+module mariso
+ use mardim, only: mx, my, mz, mw
+ use marssn, only: nsx
+ ! klonv = 1, because not
+ use mar_sv, only: nsno, klonv
+ use mar_tv, only: imx, jmx, nvx, llx
+ implicit none
+ ! niso_all : number of defined isotopes
+ integer, parameter :: niso_all = 5
+ ! niso : effective number of isotopes [2 to 4]
+ integer, parameter :: niso = 3
+ ! iso_wat : index of water
+ integer, parameter :: iso_wat = 1
+ ! iso_HDO : index of HDO
+ integer, parameter :: iso_HDO = 2
+ ! iso_O18 : index of H218O
+ integer, parameter :: iso_O18 = 3
+ ! iso_O17 : index of H217O
+ integer, parameter :: iso_O17 = 4
+ ! iso_HTO : index of tritium
+ integer, parameter :: iso_HTO = 5
+
+ ! local variables
+ ! wiso : local loop
+ integer :: wiso
+
+ ! options
+ ! =======
+ ! options for initialization
+ ! iso_init_type = 0 : R = Rdefault
+ ! iso_init_type = 1 : R from observed delta
+ integer, parameter :: iso_init_type = 0
+
+ ! parameters
+ ! ==========
+
+ ! constants
+ ! =========
+ ! initialized in mariso_constants()
+ ! negligible : minimal value for a mixing ratio to be considered as negligible
+ ! LMDZ : negligible = ridicule
+ ! if negligible, we don't test if isotopic composition is aberrant
+ real, parameter :: negligible = 1e-12
+ ! negligible_rain : negligible value for rain fluxes
+ ! negligible_rain in kg m-2 s-1 <-> 1e-3 mm day-1
+ real, parameter :: negligible_rain = 1e-8
+ ! negligible_evap : negligible value for evap fluxes
+ real, parameter :: negligible_evap = 1e-8 * 1e-2
+ ! q_minsol : negligible value for qsol
+ real, parameter :: q_minsol = 1e-8
+ ! negligible_snow : negligible value for snowpack
+ real, parameter :: negligible_snow = 1e-8
+ ! q_min : negligible value for specific humidity
+ ! LMDZ : q_min = qperemin in dyn3dmem/infotrac.f90
+ ! real, parameter :: q_min = 1.e-16
+ ! ratio_min : negligible value for isotopic ratio (q_iso / q)
+ ! LMDZ : ratio_min = ratiomin in dyn3dmem/infotrac.f90
+ ! real, parameter :: ratio_min = 1.e-16
+ ! TODO : add details on expb_max
+ real, parameter :: expb_max = 30.0
+ ! deltaO18 at ocean surface
+ real, parameter :: deltaO18_ocean = 0.
+ ! lab_iso : isotope label
+ character(len=3), save :: lab_iso(niso_all)
+ ! RNsmow : Vienna Standard Mean Ocean Water (SMOW) [mol mol-1]
+ ! LMDZ : RNsmow = tnat
+ real, save :: RNsmow(niso_all)
+ ! Rsmow : Vienna Standard Mean Ocean Water (SMOW) in mass [kg kg-1]
+ ! in the code, R is the mass ratio, so Rsmow must be converted in mass
+ ! LMDZ : Rsmow = tnat * Miso / M16
+ real, save :: Rsmow(niso_all)
+ ! Rdefault : initial ratio for all water components [mol mol-1]
+ ! TODO : check Rdefault, why these values?
+ ! todo : check if valid with the mass definition of Rsmow
+ ! LMDZ : Rdefault = Rdefault for Rdefault_smow = .true.
+ real, save :: Rdefault(niso_all)
+ ! mwl_slope : slope of meteoric water line of delta_iso vs. delta_18O [-]
+ ! LMDZ : mwl_slope = pente_MWL
+ real, save :: mwl_slope(niso_all)
+ ! fac_Rocean : correction factor for R at ocean surface [-]
+ ! Rocean = Rsmow * (1 + delta_ocean / 1000.) * (1 + fac_Rocean)
+ ! LMDZ : fac_Rocean = fac_enrichoce18 * mwl_slope
+ real, save :: fac_Rocean(niso_all)
+ ! Rocean : isotopic ratio at ocean surface [mol mol-1]
+ ! todo : check if valid with the mass definition of Rsmow
+ ! LMDZ : Rocean = toce * tcorr
+ real, save :: Rocean(niso_all)
+ ! alpha_liq_0, alpha_liq_1, alpha_liq_2 : coeff of equilibrium fractionation for liquid/vapor phases (Majoube, 1971b)
+ ! alpha_liq_0 [-], alpha_liq_1 [K], alpha_liq_2 [K2]
+ ! LMDZ : alpha_liq_0, alpha_liq_1, alpha_liq_2 = talph3, talph2, talph1
+ real, save :: alpha_liq_0(niso_all), alpha_liq_1(niso_all), alpha_liq_2(niso_all)
+ ! alpha_ice_0, alpha_ice_1, alpha_ice_2 : coeff of equilibrium fractionation for ice/vapor phases (Majoube, 1971b)
+ ! alpha_ice_0 [-], alpha_ice_1 [K], alpha_ice_2 [K2]
+ ! LMDZ : alpha_ice_0, alpha_ice_1, alpha_ice_2 = talps2, talps1
+ ! TODO : update with Ellehøj et al. (2013) ? (see with M. Casado)
+ real, save :: alpha_ice_0(niso_all), alpha_ice_1(niso_all), alpha_ice_2(niso_all)
+ ! kcin [-] : kinetic factor for surface evaporation, with alphak = 1 / (1 - kcin)
+ ! ws0cin : wind speed limit for computing kcin [m s-1]
+ ! todo : update the equation of evaporation over ocean kcin with Françoise
+ ! kcin_0, kcin_1, kcin_2 : kcin = kcin0 for ws < ws0cin and kcin = kcin1 * ws + kcin2 for ws > ws0cin
+ ! LMDZ : kcin_0, kcin_1, kcin_2 = tkcin0, tkcin1, tkcin2 ; ws0cin = tv0cin
+ real, parameter :: ws0cin = 7.
+ real, save :: kcin_0(niso_all), kcin_1(niso_all), kcin_2(niso_all)
+ ! diffus_rel : ratio of molecular diffusivities D/Di, with alphak = (D/Di)**diffus_exp
+ ! in LMDZ : from Merlivat (1978), here updated with Barkan and Luz (2007)
+ ! LMDZ : diffus_rel = tdifrel
+ real, save :: diffus_rel(niso_all)
+ ! diffus_exp : exponent of relative diffusivity in Stewart (1975), alpha_eff for equilibrium below cloud base
+ ! LMDZ : diffus_exp = tdifexp
+ real, parameter :: diffus_exp = 0.58
+ ! diffus_exp_sol : exponent of relative diffusivity, parametrization of turbulence.
+ ! Usually equal to 0.58, but Mathieu and Bariac find the exponent to be between 0.67 and 1
+ ! diffus_exp = 0.67 for dry soils and diffus_exp = 1. for saturated soils.
+ ! LMDZ : diffus_exp_sol = tdifexp_sol
+ ! todo : check tdifexp_sol in LMDZ wateriso, might be equal to 0.8
+ real, parameter :: diffus_exp_sol = 0.67
+ ! rapport des ln(alphaeq) entre O18 et O17, donné par Amaelle
+ 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
+ !--------------------------------------------------------------
+ ! tmelt : temperature at which ice condensate starts to form (valeur ECHAM?) (K)
+ ! LMDZ : tmelt = pxtmelt
+ real, parameter :: tmelt = 273.15
+ ! tice : temperature at which all condensate is ice (K)
+ ! LMDZ : tice = pxtice
+ real, parameter :: tice = 273.15 - 10.0
+ ! frac_tmin, frac_tmax : minimum and maximun temperature to calculate fractionation coeff (K)
+ ! note : coeffs were measured only above -40!
+ ! LMDZ : frac_tmin = pxtmin, frac_tmax = pxtmax
+ ! frac_tmin : valeur minimum de la température en K. Si elle est de l'ordre de quelques K seulement,
+ ! les coeffs de fractionnement deviennent démesurément grands, et en plus ça fait planter l'execution à l'idris.
+ real, parameter :: frac_tmin = 273.15 - 120.0
+ real, parameter :: frac_tmax = 273.15 + 60.0
+ ! factors lambda_sursat and mu in Si = musi - lambda_sursat * T
+ real, parameter :: musi = 1.0
+ ! Kd : diffusion in soil (m2/s)
+ real, parameter :: Kd = 2.5e-9 !
+ ! main isotopic parameters, from LMDZ DefLists/iso.def
+ ! ====================================================
+ ! lambda_sursat : supersaturation. Typical value: 0.002. Range: 0 (no supersaturation) to 0.004 (high supersaturation)
+ real, parameter :: lambda_sursat = 0.002
+ ! thumxt1: modulate cinetic fractionation during droplets re-evaporations. Typical value: 0.9. Range: 0 (rh near droplets = rh around droplets, strong cinetic fractionation) - 1 (rh = 1 near droplets, no cinetic fractionation)
+ real, parameter :: thumxt1 = 0.9
+ ! h_land_ice // todo : h_land_ice not relevant for MAR (?)
+ ! P_veg: fraction de l'evaporation continentale provenant de la transpiration sans fractionnement de la végétation, au lieu de l évaporation avec fractionnement de sol nu ou d"eau libre. Valeur standard: 1 (comme autres GCMs). Range: 0 - 1.
+ ! P_veg = 1.0 // todo : P_veg not relevant for MAR (?)
+ ! iso_nudging: if .true. isotope H2O16 is nudged toward normal water. If .false., no nudging. In general, set to .true., but we check if H2O16 = iso_wat is not too far from normal water.
+ ! LMDZ : iso_nudging = bidouille_anti_divergence
+ logical, parameter :: iso_nudging = .true.
+ ! essai_convergence: si T, on fait tout exactement comme pour l eau normale, pour que les 2 versions convergent. Si F, on modifie un peu: ex: initialisations suppl�mentaires de variables, on zappe l homog�n�isation sous le nuage dans cv3_yield...
+ ! essai_convergence = .false. // todo : essai_convergence not relevant for MAR (?)
+ ! initialisation_iso: la façon dont les isos sont initialisés.
+ ! - Lors du lancement de gcm:
+ ! Pour la physique:
+ ! 0: lecture d un fichier, souvent de start (phyiso_etat0_fichier.F)
+ ! > 0: initialisation des isotopes académique, donnée dans phyiso_etat0_dur.F
+ ! Pour la dynamique:
+ ! 0: lecture d un fichier (dyniso_etat0_fichier.F)
+ ! > 0: initialisation académique:
+ ! 1: isos à 0 sauf H2016 = eau normale
+ ! 2: distill de Rayleigh
+ ! 3: tout est uniforme au SMOW
+ ! En général, on met initialisation_iso = 0
+ ! - Lors du lancement de create_etat0_limit:
+ ! Pour la physique: initialisation en dure, toujours
+ ! Pour la dynamique: initialisation académique toujours:
+ ! 1: isos à 0 sauf H2016 = eau normale
+ ! 2 ou 0: distill de Rayleigh
+ ! 3: tout est uniforme au SMOW
+ ! En général, on laisse à initialisation_iso=0
+ ! initialisation_iso = 2 // todo : iso_init_type = initialisation_iso -> test different initializations?
+ ! initialisation_isotrac: comment initialiser les traceurs d'eau?
+ ! 1: idéalisé: on met toute l'eau dans le tag izone_init, 0 ailleurs
+ ! 0: en lisant dans un fichier. Possible seulement si initialisation_iso = 0
+ ! initialisation_isotrac = 1 // todo : add water tracers?
+ ! deltaO18_oce: ocean deltaO18: +1.1 for LGM, 0. for current days. Ocean dexcess and O17excess are supposed null.
+ real, parameter :: deltaO18_oce = 0.
+ ! deltaP_BL: boundary layer height for which soil water tends to equilibrate. Default: 10 mb (optim in ORCHIDEE_LMDZ)
+ real, parameter :: deltaP_BL = 10.0
+ ! ruissellement_pluie: qu'est-ce qui ruisselle? si 1: c'est la pluie qui ruisselle. elle ne s'infiltre. elle ne s'infiltre donc jamais dans un sol satur�. si 0: c'est le sol qui ruisselle. La pluie s'inglitre donc dans le sol satur�.
+ ! ruissellement_pluie = 1 // todo : ruissellement_pluie not relevant for MAR (?)
+ ! alphak_stewart: if 1, alphak=(D/Diso)^nsol ; if 0: alphak=1/(1-kcin(vsurf))
+ integer, parameter :: alphak_stewart = 1
+ ! tdifexp_sol: tdifexp_sol is the exponent of D/Diso, it parameterize turbulence. Usually equal to 0.58, but Mathieu and Bariac estimate it to be between 0.67 and 1: 0.67 for dry soils and 1 for saturated soils.
+ real, parameter :: tdifexp_sol = 0.67
+ ! deltaD_max : maximum value of deltaD, if deltaD greater than deltaD_max, model crash
+ ! LMDZ : deltaD_max = deltalim = deltalimtrac
+ real, parameter :: deltaD_max = 1000000.
+ ! dexcess_max : maximum value of dexcess_max, if dexcess greater than dexcess_max, model crash
+ real, parameter :: dexcess_max = 2000
+ ! O17 limits : todo O17 limits
+ ! O17_verif = y
+ ! o17excess_bas = -1000.0
+ ! o17excess_haut = 900.0
+ ! nlevmaxO17 = 18
+ ! water tagging : todo water tagging
+ ! quand on utilise tag 17, on taggue la vapeur résiduelle quand la fraction condensée est supérieure à seuil_tag_tmin, c'est à dire quand l'évènement de condensation affecte suffisemment la compo de la vapeur résiduelle.
+ ! Si seuil_tag_tmin=0, le moindre évènement de condensation même très faible agit sur les tags, et les proportions de sfc, condensat et rev sont presques nulles.
+ ! par defaut: seuil_tag_tmin=0.01: 1% de condensation <-> 0.1 permil d'effet sur la vapeur résiduelle.
+ ! seuil_tag_tmin = 0.01
+ ! idem pour condensation dans LS: par defaut égal à seuil_tag_tmin
+ ! seuil_tag_tmin_ls = 0.01
+ ! option_seuil_tag_tmin: si 1, on recolorise la vapeur résiduelle dès que cond/qt>seuil_tag_tmin.
+ ! Ca taggue bien la vap résiduelle mais le problème est que plus on humidifie par la microphysique, plus le seuil est facilement atteint -> plus on retaggue -> au final, on n'a pas plus de tag mcrophysique alors que c'est la source d'humdification.
+ ! dans l'option 2: on taggue si (cond-qmicro)/((qt-qmicro)>seuil
+ ! option_seuil_tag_tmin = 2
+ ! lim_tag20 : latitude de taggage des extra-tropiques quand option de taggage no 20
+ ! 35.0 b defaut
+ ! lim_tag20 = 35.0
+ ! quand tag9, recolorise t'on que le condensat convectif (option 2) ou aussi le condensat starti (otion 1)
+ ! option_cond = 2
+ ! quand tag 22, on recolorise la vapeur dans les zones ou precip>lim_precip_tag22
+ ! 10.0 par défaut
+ ! lim_precip_tag22 = 10.0
+ ! no_pce : if =1, no post-condensational exchanges as in Field, Jones and Brown. no_pce = 0 : fractionation as usual.
+ ! integer, parameter :: no_pce = 0
+ ! quand adv 14, saturation limiter tel que on advec min (q,A_satlim*qs)
+ ! par defaut, A_satlim=1: c'est le code original de Francis Codron
+ ! ce param n'a d'effet que quand adv 14.
+ ! A_satlim = 0.8
+ ! si ok_restrict_A_satlim=1, alors on n'active adv 14 que dans les extra-tropiques
+ ! si ok_restrict_A_satlim=2, alors on n'active adv 14 que dans les tropiques
+ ! si ok_restrict_A_satlim=3, alors on n'active adv 14 nulle part
+ ! ok_restrict_A_satlim = 0
+ ! defaut: 2; pour adv 10: 0
+ ! slope_limiter = 2.
+ ! on multiplie par 3 ratqs aux extraropiques si modif_ratqs=1.
+ ! modif_ratqs = 0
+
+ ! variables
+ ! =========
+
+ ! svasav : sisvat snow water
+ ! --------------------------
+ ! rosSNo_iso : Snow Volumic Mass [kg/m3]
+ real, save :: rosSNo_iso(niso, mx, my, nsx, nsno)
+ ! wasSNo_iso: Soil humidity content (=> in the snow cover ) [kg/kg]
+ real, save :: wasSNo_iso(niso, mx, my, nsx, nsno)
+ ! SWaSNo_iso: Surficial Water Mass [kg/m2]
+ real, save :: SWaSNo_iso(niso, mx, my, nsx)
+ ! snohSN_iso : Snow Buffer Layer Thickness [mmWE]
+ real, save :: snohSN_iso(niso, mx, my, nsx)
+
+ ! soil water
+ ! ----------
+ ! eta_TV : Soil Moisture Content [m3/m3]
+ real, save :: eta_TV_iso(niso, imx, jmx, nvx, llx)
+ ! evapTV: Time Integrated Evapotranspiration [mm w.e.]
+ real, save :: evapTV_iso(niso, imx, jmx)
+
+ ! surface air water (for soil)
+ ! ----------------------------
+ ! qvapSL : specific humidity close to the surface (kg/kg)
+ real, save :: qvapSL_iso(niso, mx, my)
+ ! SLuqs_iso :: Surface Specific Humidity Turbulent Flux (Av.) (kg/kg m/s)
+ ! evaporation flux from the surface
+ real, save :: SLuqs_iso(niso, mx, my)
+ ! SLuqsl_iso :: Surface Specific Humidity Turbulent Flux by mosaic (kg/kg m/s)
+ ! evaporation flux from the surface by mosaic
+ real, save :: SLuqsl_iso(niso, mx, my, mw)
+ ! uqs_SV <-> SLuqsl_iso in sisvat
+ real, save :: uqs_SV_iso(niso, klonv)
+
+ ! dynamical variables
+ ! -------------------
+ ! qvDY_iso : Specific Humidity (kg/kg)
+ real, save :: qvDY_iso(niso, mx, my, mz)
+
+ ! microphysics water
+ ! ------------------
+ !cCA : quid de : snfHY = 0.0, sblHY, rnfHY, evpHY? (see iniphy)
+ ! qiHY : cloud ice crystals concentration (kg/kg)
+ real, save :: qiHY_iso(niso, mx, my, mz)
+ ! qsHY : snow flakes concentration (kg/kg)
+ real, save :: qsHY_iso(niso, mx, my, mz)
+ ! qwHY : cloud dropplets concentration (kg/kg)
+ real, save :: qwHY_iso(niso, mx, my, mz)
+ ! qrHY : rain concentration (kg/kg)
+ real, save :: qrHY_iso(niso, mx, my, mz)
+ ! rainHY : integrated precipited rain
+ real, save :: rainHY_iso(niso, mx, my)
+ ! rai0HY : integrated precipited rain (previous time step)
+ real, save :: rai0HY_iso(niso, mx, my)
+ ! snowHY : integrated precipited/eroded snow
+ real, save :: snowHY_iso(niso, mx, my)
+ ! sno0HY : integrated precipited/eroded snow (previous time step)
+ real, save :: sno0HY_iso(niso, mx, my)
+ ! sfa0HY : integrated precipited snow (previous time step)
+ real, save :: sfa0HY_iso(niso, mx, my)
+ real, save :: crysHY_iso(niso, mx, my)
+ ! qsrfHY : Blowing Snow Concentration (0.325 m above the surface)
+ real, save :: qsrfHY_iso(niso, mx, my)
+ ! qSalSV <-> qsrfHY in sisvat
+ real, save :: qSalSV_iso(niso, klonv)
+
+ ! convective water
+ ! ----------------
+ real, save :: dqv_CA_iso(niso, mx, my, mz)
+ real, save :: dqw_CA_iso(niso, mx, my, mz)
+ real, save :: dqi_CA_iso(niso, mx, my, mz)
+ real, save :: drr_CA_iso(niso, mx, my)
+ real, save :: dss_CA_iso(niso, mx, my)
+ real, save :: dsn_CA_iso(niso, mx, my)
+ real, save :: rainCA_iso(niso, mx, my)
+ real, save :: snowCA_iso(niso, mx, my)
+
+contains
+
+ subroutine mariso_constants()
+ ! initialization of constant values for water isotopes
+ implicit none
+ ! lab_iso : isotope label
+ lab_iso(iso_wat) = 'wat'
+ lab_iso(iso_O18) = 'O18'
+ lab_iso(iso_HDO) = 'HDO'
+ lab_iso(iso_O17) = 'O17'
+ lab_iso(iso_HTO) = 'HTO'
+ ! RNsmow : Vienna Standard Mean Ocean Water (SMOW) [mol mol-1]
+ RNsmow(iso_wat) = 1.
+ RNsmow(iso_O18) = 2005.2e-6
+ RNsmow(iso_HDO) = 155.76e-6
+ RNsmow(iso_O17) = 379.9e-6
+ RNsmow(iso_HTO) = 0.
+ ! Rsmow : SMOW in mass [kg kg-1]
+ Rsmow(iso_wat) = 1.
+ Rsmow(iso_O18) = RNsmow(iso_O18) * (18.+2.) / (16.+2.)
+ Rsmow(iso_HDO) = RNsmow(iso_HDO) * (16.+3.) / (16.+2.)
+ Rsmow(iso_O17) = RNsmow(iso_O17) * (17.+2.) / (16.+2.)
+ Rsmow(iso_HTO) = 0.
+ ! mwl_slope : slope of meteoric water line of delta_iso vs. delta_18O [-]
+ mwl_slope(iso_wat) = 0.
+ mwl_slope(iso_O18) = 1.
+ mwl_slope(iso_HDO) = 8.
+ mwl_slope(iso_O17) = 0.528
+ mwl_slope(iso_HTO) = 0.
+ ! Rdefault : initial ratio for all water components [mol mol-1]
+ Rdefault(iso_wat) = Rsmow(iso_wat) * 1.
+ Rdefault(iso_O18) = Rsmow(iso_O18) * (1.-6./1000.)
+ Rdefault(iso_HDO) = Rsmow(iso_HDO) * (1.-(6.*mwl_slope(iso_HDO) + 10.) / 1000.)
+ Rdefault(iso_O17) = Rsmow(iso_O17) * (1.-3.15 / 1000.)
+ Rdefault(iso_HTO) = 0.
+ ! fac_Rocean : correction factor for R at ocean surface [-]
+ fac_Rocean(iso_wat) = 0.
+ fac_Rocean(iso_O18) = 0.0005
+ fac_Rocean(iso_HDO) = fac_Rocean(iso_O18) * mwl_slope(iso_HDO)
+ fac_Rocean(iso_O17) = fac_Rocean(iso_O18) * mwl_slope(iso_O17)
+ fac_Rocean(iso_HTO) = 0.
+ ! Rocean : isotopic ratio for ocean [mol mol-1]
+ ! Rocean : todo : check why these formulas
+ Rocean(iso_wat) = Rsmow(iso_wat)
+ Rocean(iso_O18) = Rsmow(iso_O18) * (1.+deltaO18_ocean / 1000.) * (1.+fac_Rocean(iso_O18))
+ Rocean(iso_HDO) = Rsmow(iso_HDO) * (1.+deltaO18_ocean * mwl_slope(iso_HDO) / 1000.) * (1.+fac_Rocean(iso_HDO))
+ Rocean(iso_O17) = Rsmow(iso_O17) * (1.+deltaO18_ocean / 1000.)**mwl_slope(iso_O17) * (1.+fac_Rocean(iso_O17))
+ ! Rocean(iso_HTO) : rapport T/H = 0.2 TU Dreisigacker and Roether 1978 (corrigé par Alex Cauquoin)
+ ! todo : Rocean(iso_HTO), verify the ratio (16. + 4.) / (16. + 2.) here
+ Rocean(iso_HTO) = 4.e-19 * (16.+4.) / (16.+2.)
+ ! alpha_liq_0, alpha_liq_1, alpha_liq_2 : coeff of equilibrium fractionation for liquid/vapor phases (Majoube, 1971b)
+ alpha_liq_0(iso_wat) = 0.
+ alpha_liq_1(iso_wat) = 0.
+ alpha_liq_2(iso_wat) = 0.
+ alpha_liq_0(iso_O18) = -2.0667e-3
+ alpha_liq_1(iso_O18) = -0.4156
+ alpha_liq_2(iso_O18) = 1137.
+ alpha_liq_0(iso_HDO) = 52.612e-3
+ alpha_liq_1(iso_HDO) = -76.248
+ alpha_liq_2(iso_HDO) = 24844.
+ alpha_liq_0(iso_O17) = alpha_liq_0(iso_O18)
+ alpha_liq_1(iso_O17) = alpha_liq_1(iso_O18)
+ alpha_liq_2(iso_O17) = alpha_liq_2(iso_O18)
+ alpha_liq_0(iso_HTO) = 0.
+ alpha_liq_1(iso_HTO) = -103.87
+ alpha_liq_2(iso_HTO) = 46480.
+ ! alpha_ice_0, alpha_ice_1, alpha_ice_2 : coeff of equilibrium fractionation for ice/vapor phases (Majoube, 1971b)
+ ! TODO : update with Ellehøj et al. (2013) ? (see with M. Casado)
+ alpha_ice_0(iso_wat) = 0.
+ alpha_ice_1(iso_wat) = 0.
+ alpha_ice_2(iso_wat) = 0.
+ alpha_ice_0(iso_O18) = -0.028244
+ alpha_ice_1(iso_O18) = 11.839
+ alpha_ice_2(iso_O18) = 0.
+ alpha_ice_0(iso_HDO) = -0.0934
+ alpha_ice_1(iso_HDO) = 0.
+ alpha_ice_2(iso_HDO) = 16288.
+ alpha_ice_0(iso_O17) = alpha_ice_0(iso_O18)
+ alpha_ice_1(iso_O17) = alpha_ice_1(iso_O18)
+ alpha_ice_2(iso_O17) = alpha_ice_2(iso_O18)
+ alpha_ice_0(iso_HTO) = 0.
+ alpha_ice_1(iso_HTO) = -103.87
+ alpha_ice_2(iso_HTO) = 46480.
+ ! diffus_rel : ratio of molecular diffusivities D/Di, with alphak = (D/Di)**diffus_exp
+ diffus_rel(iso_wat) = 1.
+ ! diffus_rel(iso_O18) = 1. / 0.9723 ! Merlivat (1978)
+ diffus_rel(iso_O18) = 1./0.9691
+ ! diffus_rel(iso_HDO) = 1. / 0.9755 ! Merlivat (1978)
+ diffus_rel(iso_HDO) = 1./0.9839
+ ! diffus_rel(iso_O17) = 1. / 0.985452 ! donné par Amaelle
+ diffus_rel(iso_O17) = 1./0.98555 ! valeur utilisée en 1D et dans modèle de LdG
+ diffus_rel(iso_HTO) = 1./0.968
+ ! kcin_0, kcin_1, kcin_2 : kinetic factors for surface evaporation, with alphak = 1 / (1 - kcin)
+ kcin_0(iso_wat) = 0.
+ kcin_1(iso_wat) = 0.
+ kcin_2(iso_wat) = 0.
+ kcin_0(iso_O18) = 0.006
+ kcin_1(iso_O18) = 0.000285
+ kcin_2(iso_O18) = 0.00082
+ kcin_0(iso_HDO) = kcin_0(iso_O18) * (diffus_rel(iso_HDO) - 1.) / (diffus_rel(iso_O18) - 1.)
+ kcin_1(iso_HDO) = kcin_1(iso_O18) * (diffus_rel(iso_HDO) - 1.) / (diffus_rel(iso_O18) - 1.)
+ kcin_2(iso_HDO) = kcin_2(iso_O18) * (diffus_rel(iso_HDO) - 1.) / (diffus_rel(iso_O18) - 1.)
+ kcin_0(iso_O17) = kcin_0(iso_O18) * (diffus_rel(iso_O17) - 1.) / (diffus_rel(iso_O18) - 1.)
+ kcin_1(iso_O17) = kcin_1(iso_O18) * (diffus_rel(iso_O17) - 1.) / (diffus_rel(iso_O18) - 1.)
+ kcin_2(iso_O17) = kcin_2(iso_O18) * (diffus_rel(iso_O17) - 1.) / (diffus_rel(iso_O18) - 1.)
+ kcin_0(iso_HTO) = 0.01056
+ kcin_1(iso_HTO) = 0.0005016
+ kcin_2(iso_HTO) = 0.0014432
+ endsubroutine mariso_constants
+
+ real function R_to_delta(iso, Riso) result(delta)
+ implicit none
+ integer, intent(in) :: iso
+ real, intent(in) :: Riso
+ delta = (Riso / Rsmow(iso) - 1.) / 1000.
+ endfunction R_to_delta
+
+ real function delta_to_R(iso, delta) result(Riso)
+ implicit none
+ integer, intent(in) :: iso
+ real, intent(in) :: delta
+ Riso = (delta / 1000.+1.) * Rsmow(iso)
+ endfunction delta_to_R
+
+endmodule mariso
diff --git a/MAR/code_mar/mariso_routines.f90 b/MAR/code_mar/mariso_routines.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7ff65385012420474678d6f3cfe54009c92828da
--- /dev/null
+++ b/MAR/code_mar/mariso_routines.f90
@@ -0,0 +1,384 @@
+! Created by Cécile Agosta on 21/09/2021
+! isotopic routines, taken from LMDZ6iso (Camille Risi, LMD)
+
+subroutine stewart_sublim_nofrac(qa, qa_iso, qr, qr_iso, qevap, qr_new, qr_iso_new, qa_iso_new, qevap_iso)
+ ! q, xt, rfl, xtrfl, qevfl, rfln, xtrfln, xtnew, Exi
+ ! ============================================================================================ !
+ ! From C. Risi phylmdiso/isotopes_routines_mod.F90/stewart_sublim_nofrac_vectall
+ ! sublimation (re-evaporation) of ice: we suppose no fractionation during ice sublimation
+ ! ============================================================================================ !
+ use mariso, only: niso, iso_wat, iso_nudging, negligible
+ implicit none
+
+ ! inputs
+ ! ======
+ ! qa : specific humidity (kg kg-1)
+ ! LMDZ : qa = zq
+ real, intent(in) :: qa
+ ! qa_iso : isotopic specific humidity (kg kg-1)
+ ! LMDZ : qa_iso = zxt
+ real, intent(in) :: qa_iso(niso)
+ ! qr : precipitation flux in the atmosphere (kg kg-1) *before evaporation*
+ ! LMDZ : qr = Pqisup or zrfl
+ real, intent(in) :: qr
+ ! qr_iso : isotopic precipitation flux in the atmosphere (kg kg-1)
+ ! LMDZ : qr_iso = Pxtisup or zxtrfl
+ real, intent(in) :: qr_iso(niso)
+ ! qevap : evaporation flux (kg kg-1)
+ ! LMDZ : qevap = (Eqi or zqevfl) * (fac_ftmr = fac_fluxtomixratio) for conversion from flux to mixing ratio
+ ! fac_ftmr = fac_fluxtomixratio = factor for conversion from flux to mixing ratio = g.dt/dp (1 / (kg m-2 s-1))
+ ! todo : qevap, verify the unit. Coded here in kg/kg, in LMDZ it was in flux so to be multiplied by fac_fluxtomixratio = g.dt/dp
+ real, intent(in) :: qevap
+ ! qr_new : precipitation flux in the atmosphere (kg kg-1) *after evaporation*
+ ! LMDZ : qr_new = Pqiinf or zrfln (zrfln = zrfl new = rainfall flux new)
+ real, intent(in) :: qr_new
+
+ ! outputs
+ ! =======
+ ! qr_iso_new : isotopic precipitation flux in the atmosphere (kg kg-1) *after evaporation*
+ ! LMDZ : qr_iso_new = Pxtiinf or zxtrfln (zxtrfln = zxtrfl new)
+ real, intent(out) :: qr_iso_new(niso)
+ ! qa_iso_new : isotopic specific humidity after sublimation (kg kg-1)
+ ! LMDZ : qa_iso_new = xtnew
+ real, intent(out) :: qa_iso_new(niso)
+ ! qevap_iso : isotopic evaporation (kg kg-1)
+ ! LMDZ : qevap_iso = Exi
+ real, intent(out) :: qevap_iso(niso)
+
+ ! local variables
+ real Rb0(niso)
+ integer wiso
+ !#ifdef ISOVERIF
+ !#ifdef ISOVERIF
+
+ ! traitement rapide de quelques cas particuliers
+ ! todo : check if a threshold is needed here
+ if(qr <= 0) then
+ ! no precipitation, no qr_new, no change in water vapor
+ !#ifdef ISOVERIF
+ do wiso = 1, niso
+ qr_iso_new(wiso) = 0.
+ enddo
+ if(iso_nudging) then
+ qr_iso_new(iso_wat) = qr_new
+ endif
+ if(abs(qevap) > negligible) then
+ ! attention: pour des raisons obscures, il y a parfois
+ ! de le réévaporation significative alors qu'il n'y a
+ ! aucun cristal à réévaporer.
+ ! Dans ce cas, on admet cette réévaporation obscure et
+ ! on suppose qu'elle ne change pas la composition
+ ! isotopique de la vapeur.
+ if(qa > negligible) then
+ do wiso = 1, niso
+ Rb0(wiso) = qa_iso(wiso) / qa
+ enddo
+ else
+ ! there is no water vapor.
+ ! It's anoying, but we hope water vapor will be loaded soon.
+ do wiso = 1, niso
+ Rb0(wiso) = 0.
+ enddo
+ Rb0(iso_wat) = 1.
+ endif
+ do wiso = 1, niso
+ qevap_iso(wiso) = Rb0(wiso) * qevap
+ qa_iso_new(wiso) = qa_iso(wiso) + qevap_iso(wiso)
+ enddo
+ else
+ ! all is coherent, all fluxes are null
+ do wiso = 1, niso
+ qa_iso_new(wiso) = qa_iso(wiso)
+ qevap_iso(wiso) = 0.
+ enddo
+ endif
+ !#ifdef ISOVERIF
+ else
+ ! qr is greater than 0.
+ ! qr_iso_new and qevap_iso computed without fractionation
+ do wiso = 1, niso
+ qr_iso_new(wiso) = qr_iso(wiso) / qr * qr_new
+ qevap_iso(wiso) = qr_iso(wiso) / qr * qevap
+ enddo
+ !#ifdef ISOVERIF
+ if(iso_nudging) then
+ qevap_iso(iso_wat) = qevap
+ qr_iso_new(iso_wat) = qr_new
+ endif
+ ! qa_iso_new
+ do wiso = 1, niso
+ qa_iso_new(wiso) = qa_iso(wiso) + qevap_iso(wiso)
+ qa_iso_new(wiso) = max(0., qa_iso_new(wiso))
+ enddo
+ !#ifdef ISOVERIF
+ endif
+endsubroutine stewart_sublim_nofrac
+
+subroutine iso_surf_ocean(psurf, tsurf, qas, wsas, qas_iso, fevap, fevap_iso)
+ ! LMDZ : iso_surf_ocean = calcul_iso_surf_oce_vectall
+ use mariso, only: wiso, niso, Rocean, Rdefault, negligible
+ ! ptopDY : Pressure at Model Top (kPa)
+ use mar_dy, only: ptopDY
+
+ !#ifdef ISOVERIF
+ !#ifdef ISOTRAC
+ implicit none
+
+ ! input
+ ! =====
+ ! psurf : surface pressure (kPa)
+ real, intent(in) :: psurf
+ ! tsurf : surface temperature (K)
+ real, intent(in) :: tsurf
+ ! qas : surface air specific humidity (kg/kg)
+ real, intent(in) :: qas
+ ! wsas : surface air wind speed (m s-1)
+ real, intent(in) :: wsas
+ ! qas_iso : isotopes in near surface water vapor
+ real, intent(in) :: qas_iso(niso)
+ ! fevap : evaporation flux (kg s-1)
+ real, intent(in) :: fevap
+ ! output
+ ! ======
+ ! fevap_iso : isotopic evaporation flux (kg s-1)
+ real, intent(out) :: fevap_iso(niso)
+ ! function
+ ! ========
+ real qsat0D
+ ! local
+ ! =====
+ ! rh : relative humidity
+ real :: rh
+ ! qsat : saturation specific humidity (kg/kg)
+ real qsat
+ ! alpha : fractionation factor
+ real alpha(niso)
+ ! Riso : isotopic ratio
+ real Riso(niso)
+ ! kcin : cinetic fractionation coefficient
+ real kcin(niso)
+
+ !#ifdef ISOVERIF
+ !#ifdef ISOTRAC
+ !#ifdef ISOVERIF
+
+ if(fevap > 0.) then
+ ! evaporation case
+ qsat = qsat0D(tsurf, 1., psurf, ptopDY, 1)
+ rh = qas / qsat
+ rh = min(1., max(0., rh))
+ ! fractionation vapor/liquid
+ call fractcalk(tsurf, alpha)
+ ! R of surface air
+ if(qas > negligible) then
+ do wiso = 1, niso
+ Riso(wiso) = qas_iso(wiso) / qas
+ enddo
+ else
+ !#ifdef ISOVERIF
+ do wiso = 1, niso
+ Riso(wiso) = Rdefault(wiso)
+ enddo
+ endif
+ call calcul_kcin(wsas, kcin)
+ if(rh < 0.98) then
+ do wiso = 1, niso
+ fevap_iso(wiso) = fevap * (Rocean(wiso) / alpha(wiso) - rh * Riso(wiso)) / (1.-rh) * (1.-kcin(wiso))
+ enddo
+ else
+ do wiso = 1, niso
+ fevap_iso(wiso) = fevap * Rocean(wiso) / alpha(wiso)
+ enddo
+ endif
+ !#ifdef ISOTRAC
+ !#ifdef ISOVERIF
+ !#ifdef ISOVERIF
+ !#ifdef ISOTRAC
+ else if(fevap == 0.) then
+ ! no evaporation case
+ do wiso = 1, niso
+ fevap_iso(wiso) = 0.
+ enddo
+ else
+ ! condensation case
+ ! call iso_rosee_givre(qas_iso, qas, tsurf, fevap, fevap_iso)
+ if(qas > negligible) then
+ call fractcalk(tsurf, alpha)
+ do wiso = 1, niso
+ ! methode 1: condensation à l'équilibre, approx 1er ordre
+ Riso(wiso) = qas_iso(wiso) / qas
+ fevap_iso(wiso) = fevap * alpha(wiso) * Riso(wiso)
+ ! methode 2: condensation, approche sans approximation
+ ! call condiso_liq_ice(wiso, qas_iso(wiso), qas, qevap, tsurf, 0.0, zxtice, zxtliq)
+ ! fevap_iso(wiso) = -zxtliq / dtime * Mair
+ enddo
+ else
+ do wiso = 1, niso
+ Riso(wiso) = Rdefault(wiso)
+ fevap_iso(wiso) = fevap * alpha(wiso) * Riso(wiso)
+ enddo
+ endif
+ endif
+
+ return
+endsubroutine iso_surf_ocean
+
+subroutine calcul_kcin(ws, kcin)
+ use mariso, only: wiso, niso, ws0cin, kcin_0, kcin_1, kcin_2
+ implicit none
+ ! ==========================================
+ ! computes kcin as a function of wind speed
+ ! ==========================================
+ ! input
+ ! =====
+ ! ws : surface wind speed (m s-1)
+ real, intent(in) :: ws
+ ! output
+ ! ======
+ ! kcin : cinetic fractionation coefficient
+ real, intent(out) :: kcin(niso)
+
+ if(ws < ws0cin) then
+ do wiso = 1, niso
+ kcin(wiso) = kcin_0(wiso)
+ enddo
+ else
+ do wiso = 1, niso
+ kcin(wiso) = kcin_1(wiso) * ws + kcin_2(wiso)
+ enddo
+ endif
+endsubroutine calcul_kcin
+
+subroutine iso_rosee_givre(qas_iso, qas, tsurf, fevap, fevap_iso)
+ use mariso, only: wiso, niso, negligible
+ !#ifdef ISOVERIF
+ !#ifdef ISOTRAC
+ implicit none
+ ! input
+ ! =====
+ ! fevap : evaporation flux (kg s-1)
+ real, intent(in) :: fevap
+ ! qas : surface air specific humidity (kg kg-1)
+ real, intent(in) :: qas
+ ! qas_iso : isotopic surface air specific humidity (kg kg-1)
+ real, intent(in) :: qas_iso(niso)
+ ! tsurf : surface temperature (K)
+ real, intent(in) :: tsurf
+ ! output
+ ! ======
+ ! fevap_iso : isotopic evaporation flux (kg s-1)
+ real, intent(out) :: fevap_iso(niso)
+ ! local
+ ! =====
+ ! alpha : fractionation factor
+ real alpha(niso)
+ real Riso
+ ! real zxtliq, zxtice ! (kg kg-1)
+
+ if(fevap == 0.) then
+ !#ifdef ISOVERIF
+ do wiso = 1, niso
+ fevap_iso(wiso) = 0.
+ enddo
+ return
+ endif
+
+ if(qas > negligible) then
+ call fractcalk(tsurf, alpha)
+ do wiso = 1, niso
+ ! methode 1: condensation à l'équilibre, approx 1er ordre
+ Riso = qas_iso(wiso) / qas
+ fevap_iso(wiso) = fevap * alpha(wiso) * Riso
+ ! methode 2: condensation, approche sans approximation
+ ! call condiso_liq_ice(wiso, qas_iso(wiso), qas, qevap, tsurf, 0.0, zxtice, zxtliq)
+ ! fevap_iso(wiso) = -zxtliq / dtime * Mair
+ enddo
+ else
+ write(*, *) 'iso_surf>iso_rosee_givre 3189: fevap=', fevap
+ write(*, *) 'qas=', qas
+ stop
+ endif
+endsubroutine iso_rosee_givre
+
+subroutine fractcalk(ta, alpha)
+ use mariso, only: wiso, niso, niso_all, iso_O17, iso_HTO, iso_HDO, iso_O18, iso_O17, iso_wat, frac_tmin, tmelt, &
+ alpha_liq_0, alpha_liq_1, alpha_liq_2, fac_coeff_eq17_liq, &
+ alpha_ice_0, alpha_ice_1, alpha_ice_2, fac_coeff_eq17_ice, diffus_rel, &
+ musi, lambda_sursat
+ implicit none
+ ! -------------------------------------------------------------------------
+ ! Calculation of the fractionation coefficient of water isotopes.
+ ! March 2003
+ ! Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE)
+ ! -------------------------------------------------------------------------
+ ! input
+ ! =====
+ ! ta : temperature (K)
+ real, intent(in) :: ta
+ ! output
+ ! ======
+ ! alpha : fractionation factor for liquid/vapor if (ta > tfreeze) and for ice/vapor if (ta < tfreeze)
+ ! alpha liquid/vapor > 1. and alpha ice/vapor > 1.
+ real alpha(niso)
+ ! local
+ ! =====
+ real tt ! temperature (K) = max(ta, frac_tmin)
+ real, parameter :: alpha_max = 10.
+ ! tfreeze : freezing temperature (K)
+ real, parameter :: tfreeze = 273.15
+ ! supersat : supersaturation (> 1.)
+ real :: supersat
+ real :: alphatot(niso_all)
+
+ if(ta >= tfreeze) then
+ ! fractionation over liquid water (Majoube, 1971b)
+ ! alpha liquid/vapor = Rliquid/Rvapor > 1.
+ ! ------------------------------------------------
+ tt = max(ta, frac_tmin)
+ do wiso = 1, niso
+ alpha(wiso) = exp(alpha_liq_0(wiso) + alpha_liq_1(wiso) / tt + alpha_liq_2(wiso) / (tt**2))
+ if(wiso == iso_O17) then
+ alpha(wiso) = (alpha(wiso))**fac_coeff_eq17_liq
+ endif
+ alpha(wiso) = max(min(alpha(wiso), alpha_max), 0.)
+ enddo
+ else
+ ! fractionation over ice (Majoube, 1971b)
+ ! alpha ice/vapor = Rice/Rvapor > 1.
+ ! ---------------------------------------
+ tt = max(ta, frac_tmin)
+ ! todo : verify fractionation over ice formulas
+ do wiso = 1, niso
+ alpha(wiso) = exp(alpha_ice_0(wiso) + alpha_ice_1(wiso) / tt + alpha_ice_2(wiso) / (tt**2))
+ if(wiso == iso_O17) then
+ alpha(wiso) = (alpha(wiso))**fac_coeff_eq17_ice
+ endif
+ alpha(wiso) = max(min(alpha(wiso), alpha_max), 0.0)
+ ! effective fractionation over ice if necessary
+ ! ---------------------------------------------
+ if(wiso == iso_wat) then
+ alpha(wiso) = 1.
+ else
+ if(tt < tmelt) then
+ supersat = musi - lambda_sursat * (tt - tmelt)
+ alpha(wiso) = alpha(wiso) * (supersat / (1.+alpha(wiso) * (supersat - 1.) * diffus_rel(wiso)))
+ endif
+ endif
+ alpha(wiso) = max(min(alpha(wiso), alpha_max), 0.)
+ enddo
+ endif
+endsubroutine fractcalk
+
+subroutine Riso_from_qiso(wiso, qa_iso, qa, Riso)
+ use mariso, only: negligible, Rdefault
+ implicit none
+ integer, intent(in) :: wiso
+ real, intent(in) :: qa_iso, qa
+ real, intent(out) :: Riso
+
+ if(qa > negligible) then
+ Riso = qa_iso / qa
+ else
+ Riso = Rdefault(wiso)
+ endif
+endsubroutine Riso_from_qiso
diff --git a/MAR/code_mar/mariso_test.py b/MAR/code_mar/mariso_test.py
new file mode 100644
index 0000000000000000000000000000000000000000..31c0edcde1f10ddc88d7ea04a7f4a1636543b1ae
--- /dev/null
+++ b/MAR/code_mar/mariso_test.py
@@ -0,0 +1,37 @@
+import numpy as np
+import matplotlib.pyplot as plt
+
+coeffl = {'iso_wat': {'0': 0., '1': 0., '2': 0.},
+ 'iso_O18': {'0': -2.0667e-3, '1': -0.4156, '2': 1137.},
+ 'iso_HDO': {'0': 52.612e-3, '1': -76.248, '2': 24844.},
+ 'iso_O17': {'0': -2.0667e-3, '1': -0.4156, '2': 1137.},
+ 'iso_HTO': {'0': 0., '1': -103.87, '2': 46480.}}
+
+coeffi = {'iso_wat': {'0': 0., '1': 0., '2': 0.},
+ 'iso_O18': {'0': -0.028244, '1': 11.839, '2': 0.},
+ 'iso_HDO': {'0': -0.0934, '1': 0., '2': 16288.},
+ 'iso_O17': {'0': -0.028244, '1': 11.839, '2': 0.},
+ 'iso_HTO': {'0': 0., '1': -103.87, '2': 46480.}}
+
+ttm = np.linspace(273.15-40, 273.15, 100)
+ttp = np.linspace(273.15, 273.15+100, 100)
+
+alphai_m, alphal_p = {}, {}
+for wiso in list(coeffl):
+ alphai_m[wiso] = np.exp(coeffi[wiso]['2'] / (ttm**2) + coeffi[wiso]['1'] / ttm + coeffi[wiso]['0'])
+ alphal_p[wiso] = np.exp(coeffl[wiso]['2'] / (ttp**2) + coeffl[wiso]['1'] / ttp + coeffl[wiso]['0'])
+
+plt.clf()
+wiso = 'iso_O18'
+for wiso in ['iso_O18', 'iso_HDO']:
+ plt.figure()
+ plt.plot(ttm, alphai_m[wiso])
+ plt.plot(ttp, alphal_p[wiso])
+ plt.title(wiso)
+
+plt.close('all')
+for wiso in list(coeffl):
+ plt.figure()
+ plt.plot(ttm, alphai_m[wiso])
+ plt.plot(ttp, alphal_p[wiso])
+ plt.title(wiso)
diff --git a/MAR/code_mar/mariso_visu.jnl b/MAR/code_mar/mariso_visu.jnl
new file mode 100644
index 0000000000000000000000000000000000000000..4e81410c0c8d74a621872bee03cbe6213bedcfea
--- /dev/null
+++ b/MAR/code_mar/mariso_visu.jnl
@@ -0,0 +1,14 @@
+let RNsmow_wat = 1.
+let RNsmow_O18 = 2005.2e-6
+let RNsmow_HDO = 155.76e-6
+let RNsmow_O17 = 379.9e-6
+let RNsmow_HTO = 0.
+ ! Rsmow : SMOW in mass [kg kg-1]
+let Rsmow_wat = 1.
+let Rsmow_O18 = `RNsmow_O18` * (18. + 2.) / (16. + 2.)
+let Rsmow_HDO = `RNsmow_HDO` * (16. + 3.) / (16. + 2.)
+let Rsmow_O17 = `RNsmow_O17` * (17. + 2.) / (16. + 2.)
+let Rsmow_HTO = 0.
+
+let dD = ((qvDY_HDO/qvDY_wat)/Rsmow_HDO-1.)*1000.
+let dO18 = ((qvDY_O18/qvDY_wat)/Rsmow_O18-1.)*1000.
\ No newline at end of file
diff --git a/MAR/code_mar/mariso_visu.jnl.f90 b/MAR/code_mar/mariso_visu.jnl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..89b31495b78ac0d11ce1a935ca575cb5e34f4eab
--- /dev/null
+++ b/MAR/code_mar/mariso_visu.jnl.f90
@@ -0,0 +1,14 @@
+let RNsmow_wat = 1.
+let RNsmow_O18 = 2005.2e-6
+let RNsmow_HDO = 155.76e-6
+let RNsmow_O17 = 379.9e-6
+let RNsmow_HTO = 0.
+! Rsmow : SMOW in mass [kg kg-1]
+let Rsmow_wat = 1.
+let Rsmow_O18 = `RNsmow_O18`*(18.+2.) / (16.+2.)
+let Rsmow_HDO = `RNsmow_HDO`*(16.+3.) / (16.+2.)
+let Rsmow_O17 = `RNsmow_O17`*(17.+2.) / (16.+2.)
+let Rsmow_HTO = 0.
+
+let dD = ((qvDY_HDO / qvDY_wat) / Rsmow_HDO - 1.) * 1000.
+let dO18 = ((qvDY_O18 / qvDY_wat) / Rsmow_O18 - 1.) * 1000.
diff --git a/MAR/code_mar/marlsv_mod.f90 b/MAR/code_mar/marlsv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..861805a2519becb63200a4082c052a8f36c7733e
--- /dev/null
+++ b/MAR/code_mar/marlsv_mod.f90
@@ -0,0 +1,7 @@
+! marslv
+! ======
+module marlsv
+ implicit none
+ logical, save :: iniIRs, iniOUT
+endmodule marlsv
+
diff --git a/MAR/code_mar/marmagic_mod.f90 b/MAR/code_mar/marmagic_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d8d47c50faeacf9f9cb1a5e570c24fac4f1b9ede
--- /dev/null
+++ b/MAR/code_mar/marmagic_mod.f90
@@ -0,0 +1,50 @@
+! marmagic : The famous ROCHEFORT_10 parameters ;-)
+! ==================================================
+
+! 1. To have more precipitation, humidty and LWD:
+! - cnos,cnos2 (#ur,#up, ...) in hydmic.f impact the ratio inland/margin precip
+! and the amount of precipitation
+! - uncomment the 2 lines BUGBUG in DYNadv_LFB_2p
+
+! 2. In cvagen_mnh, if OsetA0=T,
+! - higher PTdcv0 is, lower precip is
+! - lower PTscv0 is, lower precip is
+! - lower pdtCV0 is, higher precip is
+
+! 3. In PHYrad_CEP_mp.f, the cloud amount can be artificially increased
+! e.g. qw_CEP(ikl,lkl) = qw_CEP(ikl,lkl) * 1.1
+
+! 4. if MAR is too warm, you can increase the temperature filtering FIslot in grdmar.f
+module marmagic
+ implicit none
+ ! humidity_magic : [ 0 - 25 ]
+ ! ===========================
+ ! This parameter (formerly FacFIk) impacts the dissipation of humidity
+ ! higher this parameter is, higher the humdity is but warmer MAR is
+ ! About precipitation, it is dependant of the resolution.
+ ! Belgium : humidity_magic = 15.
+ ! Greenland: humidity_magic = 20.
+ real, parameter :: humidity_magic = 20.
+ ! cloud_magic : [ 0 - 1 ]
+ ! =======================
+ ! This paremeter converts x % part of QS/QR (precip) into QI/QW (clouds).
+ ! higher this parameter is, higher the cloudiness is, lower precip inland is there.
+ ! A value of 0.1 means +10%
+ ! Belgium : cloud_magic = 0.15
+ ! Greenland: cloud_magic = 0.0
+ real, parameter :: cloud_magic = 0.
+ ! correction_humidity_boundary : [ -0.3 - +0.3 ]
+ ! ==============================================
+ ! At high resolution, you need to increase the humidity at the MAR lateral boundaries.
+ ! Normally, this correction is done in NESTOR (see subroutine NSTint.f)
+ ! But here you have the possibility, to change add an additionnal correction.
+ ! A value of 0.1 means +10%
+ real, parameter :: correction_humidity_boundary = 0.0
+ ! rain_snow_limit : [271.15 - 272.15] deg K
+ ! ==========================================
+ ! for temperature = rain_snow_limit + 2 => rainfall
+ ! for temperature = rain_snow_limit => snowfall
+ real, parameter :: rain_snow_limit = 271.15 ! polar climate
+ ! Europe :: rain_snow_limit = 272.15
+endmodule marmagic
+
diff --git a/MAR/code_mar/marpen_mod.f90 b/MAR/code_mar/marpen_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..45db300f2eb1997b950ef3cef8d3f07c685e96a4
--- /dev/null
+++ b/MAR/code_mar/marpen_mod.f90
@@ -0,0 +1,14 @@
+module marpen
+ use mardim
+ implicit none
+ ! pente1, pente2 and pente3 are used in the correction
+ ! towards horizontal diffusion (hdiff and vdiff)
+ real, save :: akhm(mx, my, mz)
+ real, save :: pente1(mx, my, mz)
+ real, save :: pente2(mx, my, mz)
+ real, save :: pente3(mx, my, mz)
+ ! slopex and slopey are the slope of the sigma surfaces
+ ! in the x and y direction respectively
+ real, save :: slopex(mx, my, mzz)
+ real, save :: slopey(mx, my, mzz)
+endmodule marpen
diff --git a/MAR/code_mar/marphy_mod.f90 b/MAR/code_mar/marphy_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2c2c348f1656384d968bedfa75d103c6498d7c88
--- /dev/null
+++ b/MAR/code_mar/marphy_mod.f90
@@ -0,0 +1,170 @@
+#include "MAR_pp.def"
+module marphy
+ implicit none
+ ! labnum: Alphanumeric Character
+ character(len=1), parameter :: labnum(0:10) = (/ &
+ '0', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/)
+ ! =================
+ ! Numeric Constants
+ ! =================
+ ! izr = 0
+ integer, parameter :: izr = 0
+ ! iun = 1
+ integer, parameter :: iun = 1
+ ! zero = 0.0
+ real, parameter :: zero = 0.
+ ! demi = 0.5
+ real, parameter :: demi = 0.5
+ ! unun = 1.0
+ real, parameter :: unun = 1.
+ ! epsi = 1.0e-6
+ real, parameter :: epsi = 0.000001
+ ! eps9 = 1.0e-9
+ real, parameter :: eps9 = 0.000000001
+ ! eps12 = 1.0e-12
+ real, parameter :: eps12 = 0.000000000001
+ ! third = 1/3
+ real, parameter :: third = 1./3.
+ ! thous = 1.e3
+ real, parameter :: thous = 1000.
+ ! argmin: Function exp(x) Minimum Argument
+ real, save :: argmin
+ ! argmax: Function exp(x) Maximum Argument (Min/Max are Machine Dependant)
+ real, save :: argmax
+ ! ===================
+ ! Geometric Constants
+ ! ===================
+ ! pi = 3.141592653589793238462643e0 !cCA-to-be-changed
+ real, parameter :: pi = acos(-1.)
+ ! degrad = pi / 180.
+ real, parameter :: degrad = pi / 180.
+ ! hourad = pi / 12.
+ real, parameter :: hourad = pi / 12.
+ ! ===============
+ ! Earth Constants
+ ! ===============
+ ! earthr: Earth Radius = 6371.d+3 m
+ real, parameter :: earthr = 6378.1370e+3
+ ! earthv: Earth Angular Velocity = 7.29d-5 s-1 !cCA-verify-10-5-or-10-7
+ real, parameter :: earthv = 729.217e-7
+ ! gravit: Earth Gravity Acceleration = 9.81 m/s2
+ real, parameter :: gravit = 9.81
+ ! gravi2: gravit ** 2
+ real, parameter :: gravi2 = gravit**2.
+ ! grvinv: 1 / gravit
+ real, parameter :: grvinv = 1 / gravit
+ ! ===================
+ ! Dynamical Constants
+ ! ===================
+ ! akmol : Air Viscosity = 1.35d-5 m2/s
+ real, parameter :: akmol = 1.35e-5
+ ! vonkar: von Karman constant = 0.4
+ real, parameter :: vonkar = 0.4
+ ! A_Turb: Stability Coefficient Moment = 5.8
+ ! Stability Coefficient in the SBL Universal Stable Function
+ ! for Momentum (Cheng et al., 2005, 2004JD004923, p.3, eq.9: 5.8)
+ real, parameter :: A_Turb = 5.8
+ ! AhTurb: Stability Coefficient Heat = 5.4
+ ! Stability Coefficient in the SBL Universal Stable Function
+ ! for Heat (Cheng et al., 2005, 2004JD004923, p.3, eq.9: 5.4)
+ real, parameter :: AhTurb = 5.4
+ ! AsTurb: Stability Coefficient BLOW * = 4.0
+ ! Stability Coefficient in the SBL Universal Stable Function
+ ! for BLOW*(Bintanja, 2000, BLM 95, p.390 4.0)
+ real, parameter :: AsTurb = 4.
+ ! r_Turb: Turbulent Diffusivities Ratio K*/Km
+ ! (Bintanja, 2000, BLM 95, p. 384 3.0)
+ real, parameter :: r_Turb = 3.
+ ! ======================================
+ ! Thermodynamical Constants (Atmosphere)
+ ! ======================================
+ ! RDryAi: perfect gas law constant for dry air (287 J/kg/K)
+ real, parameter :: RDryAi = 287.05967
+ ! Ra : perfect gas law constant for dry air (287 J/kg/K)
+ real, parameter :: Ra = 287.05967
+ ! Cp : dry air specific heat at constant p (1004 J/kg/K)
+ real, parameter :: Cp = 1004.708845
+ ! CvDryA: dry air specific heat at constant V ( 717 J/kg/K)
+ real, parameter :: CvDryA = Cp - RDryAi
+ ! racv = Ra / Cv = Ra /(Cp-Ra)
+ real, parameter :: racv = RDryAi / CvDryA
+ ! cap = ra / cp
+ real, parameter :: cap = RDryAi / Cp
+ ! pcap = 100 ** (R / Cp) = 100.[kPa]**cap
+ real, parameter :: pcap = 3.7301
+ ! RVapor: perfect gas law constant Water Vapor (461 J/kg/K)
+ real, parameter :: RVapor = 461.
+ ! epsq : Minimum Water Vapor Content = 3.00d-6 kg/kg
+ real, parameter :: epsq = 3.e-6
+ ! Lv_H2O: Latent Heat Vaporisation / Water = 2500.00d+3 J/kg
+#if(EU)
+ real, parameter :: Lv_H2O = 2.2608e6
+#else
+ real, parameter :: Lv_H2O = 2.5008e6
+#endif
+ ! Ls_H2O: Latent Heat Sublimation / Ice = 2833.60d+3 J/kg
+ real, parameter :: Ls_H2O = 2.8345e6
+ ! r_LvCp [Lv=2500000J/kg]/[Cp=1004J/kg/K]= 2490.04 K/[kg/kg]
+ real, parameter :: r_LvCp = Lv_H2O / Cp
+ ! r_LcCp [Lc= 333600J/kg]/[Cp=1004J/kg/K]= 332.27 K/[kg/kg]
+ real, parameter :: r_LcCp = (Ls_H2O - Lv_H2O) / Cp
+ ! r_LsCp [Ls=2833600J/kg]/[Cp=1004J/kg/K]= 2822.31 K/[kg/kg]
+ real, parameter :: r_LsCp = Ls_H2O / Cp
+ ! stefan: Stefan Constant = 5.67d-8 W/m2/K4
+ real, parameter :: stefan = 5.67e-8
+ ! qv_MIN: Minimum Specific Humidity = 3.00d-6 kg/kg
+ ! (Christian Tricot, pers.com.)
+ real, parameter :: qv_MIN = 3.e-6
+ ! ===============================
+ ! Thermodynamical Constants (Sea)
+ ! ===============================
+ ! ------------------------------------------------------------------
+ ! cpl : constants usefull for coupled configuration (see MAR_AO.inc)
+ ! !AO_CK 20/02/2020
+ ! ------------------------------------------------------------------
+ ! cpv: water vapor specific heat (J/kg/K)
+ real, parameter :: cpv = 1846.1
+ ! cpvir: [cpv/cp - 1] (usefull value for qsat) (-)
+ real, parameter :: cpvir = 0.83746
+ ! R_Rv: [gas cste dry air=287.0] / [gas cste moist air=461.5]
+ real, parameter :: R_Rv = 0.622
+ ! EmiSnoao : Snow Emissivity
+ real, parameter :: EmiSnoao = 0.95
+ ! EmiWatao : Water Emissivity
+ real, parameter :: EmiWatao = 1.
+ ! other
+ ! -----
+ ! tfrwat: Sea-Water freezing Temperature = 271.20d+0 K
+ real, parameter :: tfrwat = 271.2
+ ! siclf : Sea-Ice Heat of Fusion = 302.00d+6 J/m3
+ real, parameter :: siclf = 302.e6
+ ! cdsice: Sea-Ice Thermal Conductivity = 2.04d+0 W/mK
+ real, parameter :: cdsice = 2.04
+ ! hic0 : Sea-Ice Initial Thickness = 2.00d+0 m
+ real, save :: hic0 = 1.
+ ! ro_Wat: Density of Water = 1000.00d+0 kg/m3
+ real, parameter :: ro_Wat = 1000.
+ ! C__Wat: Heat Capacity of Water = 4186.00d+0 J/kg/K
+ real, parameter :: C__Wat = 4186.
+ ! fracoh : 1. - 0.25
+ ! Hibler (1984): 25% of cooling => Oceanic Heat Flux (ANTARCTIC Ocean)
+ real, parameter :: fracoh = 0.75
+ ! ro_Ice: Density of Pure Ice = 920.00 kg/m3
+ real, parameter :: ro_Ice = 920.
+ ! cdice : Conductivity of Pure Ice = 2.51 W/m/K
+ real, parameter :: cdice = 2.1
+ ! TfSnow: Snow melting Temperature = 273.15 K
+ real, parameter :: TfSnow = 273.15
+ ! csnow: Heat Capacity of Snow = 2105. J/kg/K (Loth et al. 1993, JGR 98 D6, 2.2.2 2e para p.10453)
+ real, parameter :: csnow = 2105.
+ ! r0sno : Fresh Snow Density (kg/m3)
+ real, parameter :: r0sno = 30.
+ ! frsno : Fresh blowed Snow Density (kg/m3)
+ ! frsno : Fresh Snow Density (kg/m3) / calibration
+ real, parameter :: frsno = 300.
+ ! Lf_H2O: Latent Heat of Fusion of Snow (J/kg)
+ real, parameter :: Lf_H2O = 3.337e5
+ ! ===============================================
+ ! Standard Atmosphere (Winter / Middle Latitudes)
+ ! ===============================================
+endmodule marphy
diff --git a/MAR/code_mar/marqqm_mod.f90 b/MAR/code_mar/marqqm_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4ecfccb58a3e5166943690dc204d089049536473
--- /dev/null
+++ b/MAR/code_mar/marqqm_mod.f90
@@ -0,0 +1,24 @@
+! marqqm : water vapor total mass
+! ===============================
+module marqqm
+ use mardim
+ implicit none
+ integer, parameter :: lb = 1
+ integer, parameter :: lgx = min(lb + 1, mx)
+ integer, parameter :: ldx = max(1, mx - lb - 2)
+ integer, parameter :: lgy = min(lb + 1, my)
+ integer, parameter :: ldy = max(1, my - lb - 2)
+ integer, parameter :: lgx1 = max(1, lgx - 1)
+ integer, parameter :: lgx2 = max(1, lgx - 2)
+ integer, parameter :: ldx1 = min(ldx + 1, mx)
+ integer, parameter :: ldx2 = min(ldx + 2, mx)
+ integer, parameter :: lgy1 = max(1, lgy - 1)
+ integer, parameter :: lgy2 = max(1, lgy - 2)
+ integer, parameter :: ldy1 = min(ldy + 1, my)
+ integer, parameter :: ldy2 = min(ldy + 2, my)
+ integer, parameter :: lgxx = min(lgx + 1, mx)
+ integer, parameter :: ldxx = max(1, ldx - 1)
+ integer, parameter :: lgyy = min(lgy + 1, my)
+ integer, parameter :: ldyy = max(1, ldy - 1)
+ real, parameter :: f2_3 = 2./3.
+endmodule marqqm
diff --git a/MAR/code_mar/marsib_mod.f90 b/MAR/code_mar/marsib_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9621cc41b6293fdb55a686d0b360788eb097a65a
--- /dev/null
+++ b/MAR/code_mar/marsib_mod.f90
@@ -0,0 +1,20 @@
+! marsib : include sea-ice (19-02-2004)
+! =====================================
+! Commons MARsIB are used to follow MAR Sea-Ice Fraction
+module marsib
+ use mardim, only: mx, my
+ implicit none
+ ! sicsIB : Sea-Ice Fraction / Time Interpolated
+ real, save :: sicsIB(mx, my)
+ ! sic1sI : Sea-Ice Fraction / Time Step n
+ real, save :: sic1sI(mx, my)
+ ! sic2sI : Sea-Ice Fraction / Time Step n+1
+ real, save :: sic2sI(mx, my)
+ integer, save :: iyr_sI
+ integer, save :: mma_sI
+ integer, save :: jda_sI
+ integer, save :: jhu_sI
+ integer, save :: jdh_sI
+ integer(kind=8), save :: tim1sI
+ integer(kind=8), save :: tim2sI
+endmodule marsib
diff --git a/MAR/code_mar/marsnd_mod.f90 b/MAR/code_mar/marsnd_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4165b8134ee2629148248c86b47f5c8180e70cb1
--- /dev/null
+++ b/MAR/code_mar/marsnd_mod.f90
@@ -0,0 +1,35 @@
+module marsnd
+ implicit none
+ real, save :: tiSND1, tiSND2
+ ! ===============================================
+ ! Standard Atmosphere (Winter / Middle Latitudes)
+ ! ===============================================
+ ! iSND, jSND are the (x,y) coordinates of the sounding grid point
+ integer, save :: iSND
+ integer, save :: jSND
+ ! pstSND: initial model depth (kPa)
+ real, save :: pstSND
+ ! iyrSND, mmaSND, jdaSND, jhuSND
+ ! Year Month Day HourUT of the Sounding
+ integer, save :: iyrSND, mmaSND, jdaSND, jhuSND
+ ! nSND: Sounding No
+ integer, save :: nSND
+ ! loSND: 1 -> This is NOT the last Sounding
+ integer, save :: loSND
+ ! xSND : sounding characteristics
+ ! x = (tp->potential temperature
+ ! t->temperature, q->specific humidity,
+ ! z->Altitude, p->pressure, ff, dd-> large scale wind components)
+ ! ze->relative vorticity
+ ! uu,vv->Large Scale Wind Vector in MAR horiz. coord. (iSND,jSND)
+ real, save :: zSND(0:40, 2)
+ real, save :: tSND(0:40, 2)
+ real, save :: qSND(0:40, 2)
+ real, save :: pSND(0:40, 2)
+ real, save :: tpSND(0:40, 2)
+ real, save :: fSND(0:40, 2)
+ real, save :: dSND(0:40, 2)
+ real, save :: zeSND(2)
+ real, save :: uuSND(0:40)
+ real, save :: vvSND(0:40)
+endmodule marsnd
diff --git a/MAR/code_mar/marssn_mod.f90 b/MAR/code_mar/marssn_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0d2e237fa6ed9704b2c0178589581d981a501334
--- /dev/null
+++ b/MAR/code_mar/marssn_mod.f90
@@ -0,0 +1,118 @@
+! marssn : snowpack
+! ==================
+module marssn
+ use mardim
+ use mar_sv
+ implicit none
+ integer, parameter :: nsx = mw
+ ! *CL* interpolation of boundary layer variables
+ real, save, allocatable :: sh_int(:, :, :)
+ real, save, allocatable :: tairDY_int(:, :, :)
+ real, save, allocatable :: gradTM(:, :)
+ real, save, allocatable :: qvDY_int(:, :, :)
+ real, save, allocatable :: gradQM(:, :)
+ ! mskSNo: Snow/Ice Type Index
+ real, save :: mskSNo(mx, my, nsx)
+ ! nssSNo: Number of Snow Layers
+ integer, save :: nssSNo(mx, my, nsx)
+ ! nisSNo: Number of Ice Layers
+ integer, save :: nisSNo(mx, my, nsx)
+ ! issSNo: Number of superimposed Ice Layers
+ integer, save :: issSNo(mx, my, nsx)
+ ! nhsSNo: Layer historics: previous occurrence of water or faceted crystal
+ integer, save, allocatable :: nhsSNo(:, :, :, :)
+ ! tisSNo: Soil temperature (=> in the snow cover ) [K]
+ real, save, allocatable :: tisSNo(:, :, :, :)
+ ! wasSNo: Soil humidity content (=> in the snow cover ) [kg/kg]
+ real, save, allocatable :: wasSNo(:, :, :, :)
+ ! rosSNo: Snow density [kg/m3]
+ real, save, allocatable :: rosSNo(:, :, :, :)
+ ! dzsSNo: Depth of each layer of the snow cover [m]
+ real, save, allocatable :: dzsSNo(:, :, :, :)
+ ! g1sSNo: Grain Type: -99< g1 < 0 (Dendricity) 0< g1 <99 [Sphericity]
+ real, save, allocatable :: g1sSNo(:, :, :, :)
+ ! g2sSNo: Grain Type: 0< g2 <99 (Sphericity) .3mm < g2 [Size]
+ real, save, allocatable :: g2sSNo(:, :, :, :)
+ ! agsSNo: Snow Age [day]
+ real, save, allocatable :: agsSNo(:, :, :, :)
+ ! SWaSNo: Surficial Water Mass [mmWE or kg/m2]
+ real, save, allocatable :: SWaSNo(:, :, :)
+ ! SWSSNo: Surficial Water Status (0,1 = no freezing,freezing)
+ real, save, allocatable :: SWSSNo(:, :, :)
+ ! SWfSNo: Surficial Water Hydrological Model [-]
+ real, save, allocatable :: SWfSNo(:, :)
+ ! snohSN: Snow Buffer Layer Thickness [mmWE]
+ real, save, allocatable :: snohSN(:, :, :)
+ ! BrosSN: Snow Buffer Layer Density [kg/m3]
+ real, save, allocatable :: BrosSN(:, :, :)
+ ! BG1sSN: Snow Buffer Layer Dendricity / Sphericity [-]
+ real, save, allocatable :: BG1sSN(:, :, :)
+ ! BG2sSN: Snow Buffer Layer Sphericity / Size [-] [0.1 mm]
+ real, save, allocatable :: BG2sSN(:, :, :)
+ ! blowSN: Blown snow Buffer Layer Thickness [mWE]
+ real, save, allocatable :: blowSN(:, :, :)
+ ! SaltSN: Friction Velocity Saltation Threshold [m/s]
+ real, save, allocatable :: SaltSN(:, :, :)
+ ! hSalSN: Saltating Snow Thickness [mWE]
+ real, save, allocatable :: hSalSN(:, :, :)
+ ! zWE0SN: Initial Snow Thickness [mmWE]
+ real, save, allocatable :: zWE0SN(:, :, :)
+ ! zWE_SN: Current Snow Thickness [mmWE]
+ real, save, allocatable :: zWE_SN(:, :, :)
+ ! zWEcSN: Non-erodible Snow Thickness [mmWE]
+ real, save, allocatable :: zWEcSN(:, :, :)
+ ! smbsSN : Surface Mass Balance [mWE]
+ real, save, allocatable :: smbsSN(:, :, :)
+ ! sihsSN : Superimposed Ice Height [m]
+ real, save, allocatable :: sihsSN(:, :, :)
+ ! sshsSN : Slush Height [m]
+ real, save, allocatable :: sshsSN(:, :, :)
+ ! ravsSN : Averaged Density [kg/m2]
+ real, save, allocatable :: ravsSN(:, :, :)
+ ! wavsSN : Averaged Water Content [kg/kg]
+ real, save, allocatable :: wavsSN(:, :, :)
+ ! WEq_SN : Added Snow Mass [mmWE]
+ real, save, allocatable :: WEq_SN(:, :, :)
+
+contains
+
+ subroutine marssn_init()
+
+ use mardim, only: mx, my
+ implicit none
+
+ allocate(nhsSNo(mx, my, nsx, nsno))
+ allocate(sh_int(mx, my, nsx))
+ allocate(tairDY_int(mx, my, nsx))
+ allocate(gradTM(mx, my))
+ allocate(qvDY_int(mx, my, nsx))
+ allocate(gradQM(mx, my))
+ allocate(tisSNo(mx, my, nsx, nsno))
+ allocate(wasSNo(mx, my, nsx, nsno))
+ allocate(rosSNo(mx, my, nsx, nsno))
+ allocate(dzsSNo(mx, my, nsx, nsno))
+ allocate(g1sSNo(mx, my, nsx, nsno))
+ allocate(g2sSNo(mx, my, nsx, nsno))
+ allocate(agsSNo(mx, my, nsx, nsno))
+ allocate(SWaSNo(mx, my, nsx))
+ allocate(SWSSNo(mx, my, nsx))
+ allocate(SWfSNo(mx, my))
+ allocate(snohSN(mx, my, nsx))
+ allocate(BrosSN(mx, my, nsx))
+ allocate(BG1sSN(mx, my, nsx))
+ allocate(BG2sSN(mx, my, nsx))
+ allocate(blowSN(mx, my, nsx))
+ allocate(SaltSN(mx, my, nsx))
+ allocate(hSalSN(mx, my, nsx))
+ allocate(zWE0SN(mx, my, nsx))
+ allocate(zWE_SN(mx, my, nsx))
+ allocate(zWEcSN(mx, my, nsx))
+ allocate(smbsSN(mx, my, nsx))
+ allocate(sihsSN(mx, my, nsx))
+ allocate(sshsSN(mx, my, nsx))
+ allocate(ravsSN(mx, my, nsx))
+ allocate(wavsSN(mx, my, nsx))
+ allocate(WEq_SN(mx, my, nsx))
+
+ endsubroutine marssn_init
+endmodule marssn
diff --git a/MAR/code_mar/marvec_mod.f90 b/MAR/code_mar/marvec_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..37e5592bdb51f119933a7ba87e6c2e576df6bfa5
--- /dev/null
+++ b/MAR/code_mar/marvec_mod.f90
@@ -0,0 +1,34 @@
+! marvec : mar vectorization
+! ==========================
+module marvec
+ use mardim
+ implicit none
+ real, save :: vecxa(mx)
+ real, save :: vecx1(mx)
+ real, save :: vecx2(mx)
+ real, save :: vecx3(mx)
+ real, save :: vecx4(mx)
+ real, save :: vecx5(mx)
+ real, save :: vecx6(mx)
+ real, save :: delta
+ real, save :: vecy1(my)
+ real, save :: vecy2(my)
+ real, save :: vecy3(my)
+ real, save :: dumeps(mz)
+ real, save, allocatable :: dumy3D(:, :, :)
+ real, allocatable :: dumy3Q(:, :, :)
+
+
+contains
+
+ subroutine marvec_init()
+
+ use mardim, only: mx, my, mz,mzz, mw
+ implicit none
+
+ allocate(dumy3D(mx, my, mz))
+ allocate(dumy3Q(mx, my, mz))
+
+ endsubroutine marvec_init
+
+endmodule marvec
diff --git a/MAR/code_mar/marxsv_mod.f90 b/MAR/code_mar/marxsv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..49f63a562ffadb7a6488fc4a514d4313d89d5340
--- /dev/null
+++ b/MAR/code_mar/marxsv_mod.f90
@@ -0,0 +1,256 @@
+! marxsv : SISVAT INPUT Variables
+! ===============================
+module marxsv
+ use mardim
+ use mar_sv
+ implicit none
+ ! LSmask : Land-Sea Mask
+ integer :: LSmask(klonv)
+ ! isotSV : Soil Type
+ integer :: isotSV(klonv)
+ ! iWaFSV : Soil Drainage:(1,0)=(y,n)
+ integer :: iWaFSV(klonv)
+ ! ivgtSV : Vegetation Type
+ integer :: ivgtSV(klonv)
+ ! AOmask : Weight-coupling Mask (1: MAR; 0 = Oasis) !AO_CK 20/02/2020
+ real :: AOmask(klonv)
+ ! coszSV : Cosine of Sun zenithal Angle
+ real :: coszSV(klonv)
+ ! sol_SV : Downward Solar Radiation
+ real :: sol_SV(klonv)
+ ! IRd_SV : Downward Longwave Radiation
+ real :: IRd_SV(klonv)
+ ! drr_SV : Rain Intensity [kg/m2/s]
+ real :: drr_SV(klonv)
+ ! dsn_SV : Snow Intensity [kg/m2/s]
+ real :: dsn_SV(klonv)
+ ! dsnbSV : Idem, fraction, from Drift [-]
+ real :: dsnbSV(klonv)
+ ! esnbSV : Idem, fraction, from Drift [-]
+ real :: esnbSV(klonv)
+ ! dbs_SV : Drift Amount [kg/m2]
+ real :: dbs_SV(klonv)
+ ! BrosSV : Buffer Snow Layer Density
+ real :: BrosSV(klonv)
+ ! BG1sSV : Buffer Snow Layer Dendr/Sphe[-]
+ real :: BG1sSV(klonv)
+ ! BG2sSV : Buffer Snow Layer Spher/Size[-] [0.0001 m]
+ real :: BG2sSV(klonv)
+ ! dz0_SV : dz0(Sastrugi dh) [m]
+ real :: dz0_SV(klonv)
+ ! dbs_Er : BS Erosion [kg/m2]
+ real :: dbs_Er(klonv)
+ ! dbs_Ac : BS Accumulation [kg/m2]
+ real :: dbs_Ac(klonv)
+ ! cld_SV : Cloudiness (seen from SBL)
+ real :: cld_SV(klonv)
+ ! za__SV : SBL Height
+ real :: za__SV(klonv)
+ !(VV__SV : SBL Top) Wind Velocity
+ real :: VV__SV(klonv)
+ ! VV10SV : 10-m Wind Velocity
+ real :: VV10SV(klonv)
+ !(VVs_SV : Sastr,V) Relevance
+ real :: VVs_SV(klonv)
+ !(RRs_SV : Sastr,V) Counter
+ real :: RRs_SV(klonv)
+ !(DDs_SV : Sastr,V) Angle
+ real :: DDs_SV(klonv)
+ ! TaT_SV : SBL Top Temperature
+ real :: TaT_SV(klonv)
+ ! ExnrSV : Exner Potential
+ real :: ExnrSV(klonv)
+ ! dSdTSV : Sensible Heat Flux T Derivat.
+ real :: dSdTSV(klonv)
+ ! dLdTSV : Latent Heat Flux T Derivat.
+ real :: dLdTSV(klonv)
+ ! rhT_SV : SBL Top Air Density
+ real :: rhT_SV(klonv)
+ ! QaT_SV : SBL Top Specific Humidity
+ real :: QaT_SV(klonv)
+ ! dQa_SV : SBL Flux Limitation of Qa
+ real :: dQa_SV(klonv)
+ ! qsnoSV : SBL Mean Snow Content
+ real :: qsnoSV(klonv)
+ ! tsrf_SV : surface temperature(K)
+ real :: tsrf_SV(klonv)
+ ! pst_SV : surface pressure (kPa)
+ real :: pst_SV(klonv)
+ ! LAI0SV : Nominal Leaf Area Index
+ real :: LAI0SV(klonv)
+ ! glf0SV : Green Leaf Fraction
+ real :: glf0SV(klonv)
+ ! alb0SV : Soil Albedo
+ real :: alb0SV(klonv)
+ ! slopSV : Snow/Ice/Soil-Water Surf. Slope
+ real :: slopSV(klonv)
+ ! ptopSV : Pressure at Model Top (kPa)
+ real :: ptopSV
+ ! zSBLSV : SBL Height (Initial Value)
+ real :: zSBLSV
+ ! dt__SV : Time Step
+ real :: dt__SV
+ ! daHost : Date Host Model
+ character(len=18), save :: daHost
+ ! +--SISVAT INPUT/OUTPUT Variables
+ ! + -----------------------------
+ ! isnoSV : Nb of Ice/Snow Layers
+ integer :: isnoSV(klonv)
+ ! ispiSV : Uppermost superimposed ice
+ integer :: ispiSV(klonv)
+ ! iiceSV : Nb of Ice Layers
+ integer :: iiceSV(klonv)
+ ! istoSV : Snow Layer History
+ integer :: istoSV(klonv, 0:nsno)
+ ! alb_SV : Surface-Canopy Albedo
+ real :: alb_SV(klonv)
+ ! alb1SV : Snow Albedo
+ real :: alb1SV(klonv)
+ ! alb2SV : Snow Albedo
+ real :: alb2SV(klonv)
+ ! alb3SV : Snow Albedo
+ real :: alb3SV(klonv)
+ ! emi_SV : Surface-Canopy Emissivity
+ real :: emi_SV(klonv)
+ ! IRs_SV : Soil IR Flux
+ real :: IRs_SV(klonv)
+ ! LMO_SV : Monin-Obukhov Scale
+ real :: LMO_SV(klonv)
+ ! us__SV : Friction Velocity
+ real :: us__SV(klonv)
+ ! uts_SV : Temperature Turbulent Scale
+ real :: uts_SV(klonv)
+ ! cutsSV : Temperature Turbulent Scale C.
+ real :: cutsSV(klonv)
+ ! uqs_SV : Spec.Humid. Turbulent Scale
+ real :: uqs_SV(klonv)
+ ! uss_SV : Blow.Snow Turbulent Scale
+ real :: uss_SV(klonv)
+ ! usthSV : Blowing Snow Erosion Thresh.
+ real :: usthSV(klonv)
+ ! rCDmSV : Square Root Contribut. Drag_m
+ real :: rCDmSV(klonv)
+ ! rCDhSV : Square Root Contribut. Drag_h
+ real :: rCDhSV(klonv)
+ ! Z0m_SV : Momentum Roughness Length
+ real :: Z0m_SV(klonv)
+ ! Z0mmSV : z0(Momentum, Time Mean) [m]
+ real :: Z0mmSV(klonv)
+ ! Z0mnSV : z0(Momentum, instanta.) [m]
+ real :: Z0mnSV(klonv)
+ ! Z0roSV : Subgrid Topo Roughness Length
+ real :: Z0roSV(klonv)
+ ! Z0SaSV : z0(Sastrugi h) [m]
+ real :: Z0SaSV(klonv)
+ ! Z0e_SV : z0(Snow eroded) [m]
+ real :: Z0e_SV(klonv)
+ ! Z0emSV : z0(Snow eroded, Time Mean) [m]
+ real :: Z0emSV(klonv)
+ ! Z0enSV : z0(Snow eroded, instanta.) [m]
+ real :: Z0enSV(klonv)
+ ! Z0h_SV : Heat Roughness Length
+ real :: Z0h_SV(klonv)
+ ! Z0hmSV : z0(Heat, Time Mean) [m]
+ real :: Z0hmSV(klonv)
+ ! Z0hnSV : z0(Heat, instanta.) [m]
+ real :: Z0hnSV(klonv)
+ ! snCaSV : Canopy Snow Thickness
+ real :: snCaSV(klonv)
+ ! rrCaSV : Canopy Water Content
+ real :: rrCaSV(klonv)
+ ! psivSV : Leaf Water Potential
+ real :: psivSV(klonv)
+ ! TvegSV : Vegetation Temperature
+ real :: TvegSV(klonv)
+ ! TsisSV : Snow/Ice/Soil-Water Temperature
+ real :: TsisSV(klonv, -nsol:nsno)
+ ! ro__SV : Snow/Ice/Soil-Water VolumicMass
+ real :: ro__SV(klonv, -nsol:nsno)
+ ! eta_SV : Snow/Ice/Soil Water Content
+ real :: eta_SV(klonv, -nsol:nsno)
+ ! G1snSV : Snow Dendricity/Sphericity
+ real :: G1snSV(klonv, 0:nsno)
+ ! G2snSV : Snow Sphericity/Size
+ real :: G2snSV(klonv, 0:nsno)
+ ! dzsnSV : Snow Layer Thickness
+ real :: dzsnSV(klonv, 0:nsno)
+ ! agsnSV : Snow Age
+ real :: agsnSV(klonv, 0:nsno)
+ ! BufsSV : Snow Buffer Layer
+ real :: BufsSV(klonv)
+ ! rusnSV : Surficial Water
+ real :: rusnSV(klonv)
+ ! SWf_SV : Normalized Decay
+ real :: SWf_SV(klonv)
+ ! SWS_SV : Surficial Water Status
+ real :: SWS_SV(klonv)
+ ! HFraSV : Frazil Thickness
+ real :: HFraSV(klonv)
+ ! zWE_SV : Current Snow Thickness [mmWE]
+ real :: zWE_SV(klonv)
+ ! zWEcSV : Compacted Snow Thickness [mmWE]
+ real :: zWEcSV(klonv)
+ ! wem_SV : Only Melting [mmWE]
+ real :: wem_SV(klonv)
+ ! wer_SV : Refreezing [mmWE]
+ real :: wer_SV(klonv)
+ ! wee_SV : Evapo/Sublimation [mmWE]
+ real :: wee_SV(klonv, 4)
+ ! zn4_SV : snowheight change [mm]
+ real :: zn4_SV(klonv)
+ ! zn5_SV : snowheight change [mm]
+ real :: zn5_SV(klonv)
+ ! +--SISVAT OUTPUT Variables
+ ! + -----------------------------
+ ! no__SV : OUTPUT file Unit Number
+ integer :: no__SV(nb_wri)
+ ! i___SV : OUTPUT point i Coordinate
+ integer :: i___SV(nb_wri)
+ ! j___SV : OUTPUT point j Coordinate
+ integer :: j___SV(nb_wri)
+ ! n___SV : OUTPUT point n Coordinate
+ integer :: n___SV(nb_wri)
+ ! lwriSV : OUTPUT point vec Index
+ integer :: lwriSV(klonv)
+ ! ii__SV : WORK point i Coordinate
+ integer :: ii__SV(klonv), iwr_SV
+ ! jj__SV : WORK point j Coordinate
+ integer :: jj__SV(klonv), jwr_SV
+ ! nn__SV : WORK point n Coordinate
+ integer :: nn__SV(klonv), nwr_SV
+ ! IRu_SV : UPward IR Flux (effective)
+ real :: IRu_SV(klonv)
+ ! hSalSV : Saltating Layer Height
+ real :: hSalSV(klonv)
+ ! qSalSV : Saltating Snow Concentration
+ real :: qSalSV(klonv)
+ ! RnofSV : RunOFF Intensity
+ real :: RnofSV(klonv)
+ ! RuofSV : RunOFF Intensity
+ real :: RuofSV(klonv, 6)
+ common / xSISVAT_I / LSmask, ivgtSV, isotSV, iWaFSV &
+ , isnoSV, ispiSV, iiceSV, istoSV &
+ , no__SV, i___SV, j___SV, n___SV, lwriSV &
+ , ii__SV, jj__SV, nn__SV &
+ , iwr_SV, jwr_SV, nwr_SV
+ common / xSISVAT_R / AOmask, coszSV, sol_SV, IRd_SV &
+ , drr_SV, dsn_SV, dsnbSV, esnbSV, dbs_SV &
+ , BrosSV, BG1sSV, BG2sSV, dz0_SV &
+ , cld_SV, za__SV, VV__SV, VV10SV, TaT_SV, ExnrSV &
+ , VVs_SV, RRs_SV, DDs_SV &
+ , dSdTSV, dLdTSV, rhT_SV, QaT_SV, qsnoSV, tsrf_SV, pst_SV &
+ , LAI0SV, glf0SV, alb0SV, slopSV, zSBLSV, dt__SV &
+ , alb_SV, emi_SV, IRs_SV &
+ , LMO_SV, us__SV, uts_SV, cutsSV, uqs_SV, uss_SV, usthSV &
+ , rCDmSV, rCDhSV, ptopSV &
+ , Z0m_SV, Z0mnSV, Z0mmSV, Z0roSV, Z0SaSV &
+ , Z0e_SV, Z0enSV, Z0emSV, zn4_SV, zn5_SV &
+ , Z0h_SV, Z0hnSV, Z0hmSV, snCaSV, rrCaSV &
+ , psivSV, TvegSV, TsisSV, ro__SV, eta_SV &
+ , G1snSV, G2snSV, dzsnSV, agsnSV, BufsSV, rusnSV, SWf_SV &
+ , SWS_SV, HFraSV, IRu_SV, hSalSV, qSalSV, RnofSV, RuofSV &
+ , zWE_SV, zWEcSV, wem_SV, wer_SV, wee_SV &
+ , alb1SV, alb2SV, alb3SV, dbs_Er, dbs_Ac
+ save
+ !$OMP threadprivate(/xSISVAT_I/,/xSISVAT_R/)
+endmodule marxsv
diff --git a/MAR/code_mar/marysv_mod.f90 b/MAR/code_mar/marysv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..564938d9c2d8bc0c6f11e5867a86c93ff7607575
--- /dev/null
+++ b/MAR/code_mar/marysv_mod.f90
@@ -0,0 +1,91 @@
+module marysv
+ use mardim
+ use mar_sv
+ implicit none
+ ! NLaysv : New Snow Layer Switch
+ integer :: NLaysv(klonv)
+ ! i_thin : Index of the thinest Layer
+ integer :: i_thin(klonv)
+ ! LIndsv : Contiguous Layer relative Index
+ integer :: LIndsv(klonv)
+ ! albisv : Integrated Surface Albedo
+ real :: albisv(klonv)
+ ! albssv : Soil Albedo [-]
+ real :: albssv(klonv)
+ ! SeaalbAOsisv : Ice/Snow Albedo from NEMO !AO_CK 20/02/2020
+ real :: albAOsisv(klonv)
+ ! SoCasv : Canopy Absorbed Solar Radiat.
+ real :: SoCasv(klonv)
+ ! SoSosv : Surface Absorbed Solar Radiat.
+ real :: SoSosv(klonv)
+ ! IRv_sv : Vegetation IR Flux [W/m2]
+ real :: IRv_sv(klonv)
+ ! Evg_sv : Emissivity of Vegetation+Snow
+ real :: Evg_sv(klonv)
+ ! Eso_sv : Emissivity of Soil+Snow
+ real :: Eso_sv(klonv)
+ ! tau_sv : Transmited Radiation Fraction
+ real :: tau_sv(klonv)
+ ! rrMxsv : Canopy Maximum Intercepted Rain
+ real :: rrMxsv(klonv)
+ ! LAIesv : effective LAI for transpirati.
+ real :: LAIesv(klonv)
+ ! LAI_sv : corrected LAI in case of snow
+ real :: LAI_sv(klonv)
+ ! glf_sv : Green Leaf Fraction
+ real :: glf_sv(klonv)
+ ! Sigmsv : Canopy Ventilation Factor
+ real :: Sigmsv(klonv)
+ ! HSv_sv : Sensible Heat Flux [W/m2]
+ real :: HSv_sv(klonv)
+ ! HLv_sv : Latent Heat Flux [W/m2]
+ real :: HLv_sv(klonv)
+ ! HSs_sv : Sensible Heat Flux (t)
+ real :: HSs_sv(klonv)
+ ! HLs_sv : Latent Heat Flux (t)
+ real :: HLs_sv(klonv)
+ ! sqrCm0 : in Neutral Drag Coef.Moment.
+ real :: sqrCm0(klonv)
+ ! sqrCh0 : in Neutral Drag Coef.Heat
+ real :: sqrCh0(klonv)
+ ! Lx_H2O : Latent Heat of Vaporiz./Sublim.
+ real :: Lx_H2O(klonv)
+ ! ram_sv : Aerodyn.Resistance (Moment.)
+ real :: ram_sv(klonv)
+ ! rah_sv : Aerodyn.Resistance (Heat)
+ real :: rah_sv(klonv)
+ ! Fh__sv : Stability Function
+ real :: Fh__sv(klonv)
+ ! dFh_sv : Stability Function (Deriv.)
+ real :: dFh_sv(klonv)
+ ! Evp_sv : Evaporation [kg/m2]
+ real :: Evp_sv(klonv)
+ ! EvT_sv : Evapotranspiration [kg/m2]
+ real :: EvT_sv(klonv)
+ ! LSdzsv : Land/Sea Vert. Discretiz. Fact.
+ real :: LSdzsv(klonv)
+ ! Tsrfsv : Surface Temperature
+ real :: Tsrfsv(klonv)
+ ! sEX_sv : Verticaly Integr.Extinct.Coef.
+ real :: sEX_sv(klonv, -nsol:nsno + 1)
+ ! zzsnsv : Snow Pack Thickness [m]
+ real :: zzsnsv(klonv, 0:nsno)
+ ! psi_sv : Soil Water Potential
+ real :: psi_sv(klonv, -nsol:0)
+ ! Khydsv : Soil Hydraulic Conductiv.
+ real :: Khydsv(klonv, -nsol:0)
+ ! Rootsv : Root Water Pump [kg/m2/s]
+ real :: Rootsv(klonv, -nsol:0)
+ ! EExcsv : Energy in Excess, current
+ real :: EExcsv(klonv)
+ common / ySISVAT_I / NLaysv, i_thin, LIndsv
+ common / ySISVAT_R / albisv, albssv, albaosisv, SoCasv, &
+ SoSosv, IRv_sv, Evg_sv, Eso_sv, tau_sv, &
+ rrMxsv, LAIesv, LAI_sv, glf_sv, &
+ Sigmsv, HSv_sv, HLv_sv, HSs_sv, HLs_sv, &
+ sqrCm0, sqrCh0, Lx_H2O, ram_sv, rah_sv, Evp_sv, EvT_sv, &
+ LSdzsv, Tsrfsv, sEX_sv, zzsnsv, &
+ psi_sv, Khydsv, Rootsv, EExcsv
+ save
+ !$OMP threadprivate(/ySISVAT_I/,/ySISVAT_R/)
+endmodule marysv
diff --git a/MAR/code_mar/matinv.f90 b/MAR/code_mar/matinv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a286cd7864169002874de1ae8c0c4f081bd09c6a
--- /dev/null
+++ b/MAR/code_mar/matinv.f90
@@ -0,0 +1,115 @@
+subroutine matinv(wk1, wk2, l_min, l_max)
+ ! +
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS LBC 27-09-2001 MAR |
+ ! | subroutine matinv performs a Matrix Inversion using a Companion |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : wk1 : Matrix to be inverted |
+ ! | ^^^^^^^^ Dimension : (lmin:lmax) -> jdim=lmax-lmin+1 |
+ ! | This Matrix is Loss after the Matrix Inversion |
+ ! | |
+ ! | OUTPUT : wk2 : Inverted Matrix |
+ ! | ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ implicit none
+
+ ! +--Input Output Variables
+ ! + ======================
+ integer, intent(in) :: l_min
+ integer, intent(in) :: l_max
+ real, intent(inout) :: wk1(l_min:l_max, l_min:l_max)
+ real, intent(out) :: wk2(l_min:l_max, l_min:l_max)
+
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer l, k, ll, llp1, llx1, llm1
+ real xx, yy
+
+ ! +--wk2 = Compagnion Matrix = Unity Matrix
+ ! + --------------------------------------
+ ! +
+ do l = l_min, l_max
+ do k = l_min, l_max
+ wk2(l, k) = 0.d0
+ enddo
+ wk2(l, l) = 1.d0
+ enddo
+ ! +
+ ! +...Combinaisons lineaires de lignes de la matrice wk1 de facon a y faire
+ ! + apparaitre des 0 dans le triangle inferieur et des 1 sur la diagonale.
+ ! + Memes operations effectuees systematiquement sur la matrice compagnon.
+ ! +
+ ll = l_min
+50 llp1 = ll + 1
+ xx = wk1(ll, ll)
+ ! +
+ ! +...Si l'element diagonal est nul,la ligne le contenant est interchangee
+ ! + avec une des suivantes...jusqu'a ce qu'on obtienne un element non nul.
+ ! + Dans le cas contraire la matrice est singuliere.
+ ! +
+ if(xx == 0.0d0) then
+ llx1 = ll + 1
+90 if(wk1(llx1, llx1) == 0.0d0) then
+ llx1 = llx1 + 1
+ if(llx1 > l_max) write(21, *) 'Matrice non inversible'
+ go to 90
+ endif
+ do k = l_min, l_max
+ yy = wk1(ll, k)
+ wk1(ll, k) = wk1(llx1, k)
+ wk1(llp1, k) = yy
+ yy = wk2(ll, k)
+ wk2(ll, k) = wk2(llx1, k)
+ wk2(llp1, k) = yy
+ enddo
+ xx = wk1(ll, ll)
+ endif
+ ! +
+ ! +...Division pour obtenir 1 sur la diagonale
+ ! +
+ do k = l_min, l_max
+ wk1(ll, k) = wk1(ll, k) / xx
+ wk2(ll, k) = wk2(ll, k) / xx
+ enddo
+ ! +
+ ! +...Soustraction pour obtenir 0 dans le triangle inferieur
+ ! +
+ do l = llp1, l_max
+ xx = wk1(l, ll)
+ do k = l_min, l_max
+ wk1(l, k) = wk1(l, k) - xx * wk1(ll, k)
+ wk2(l, k) = wk2(l, k) - xx * wk2(ll, k)
+ enddo
+ enddo
+ ! +
+ ! +...Passage a la ligne suivante
+ ! +
+ if(ll < l_max) then
+ ll = ll + 1
+ go to 50
+ endif
+ ! +
+ ! +...Combinaisons lineaires effectuees sur la matrice wk1
+ ! + pour y faire apparaitre des 0 dans le triangle superieur.
+ ! + Memes operations effectuees sur la matrice compagnon
+ ! +
+ ll = l_max
+60 llm1 = ll - 1
+ do l = llm1, l_min, -1
+ xx = wk1(l, ll)
+ do k = l_min, l_max
+ wk1(l, k) = wk1(l, k) - xx * wk1(ll, k)
+ wk2(l, k) = wk2(l, k) - xx * wk2(ll, k)
+ enddo
+ enddo
+ if(ll > l_min) then
+ ll = ll - 1
+ go to 60
+ endif
+ ! +
+ return
+end
diff --git a/MAR/code_mar/oasis_2_mar.f90 b/MAR/code_mar/oasis_2_mar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1c8cd4ee39f46f3b54493b789fa413b649290e58
--- /dev/null
+++ b/MAR/code_mar/oasis_2_mar.f90
@@ -0,0 +1,134 @@
+subroutine OASIS_2_MAR
+
+ ! +--------------------------------------------------------------------------+
+ ! | 20-20-2020|
+ ! | subroutine OASIS_2_MAR transfers OASIS variables to MAR |
+ ! | |
+ ! | |
+ ! | A chaque pas de temps, fromcpl est appele ; |
+ ! | si il_time_secs est egal a un multiple de la periode de couplage |
+ ! | alors son action est effective (via oasis_get), |
+ ! | et MAR recupere les champs de NEMO via getfld (oasis) |
+ ! | |
+ ! | C. Kittel + P-V. Huot + N. Jourdain |
+ ! | cf mar_module.f90 |
+ ! | cf OASIS-3 user guide (december 2004) |
+ ! +--------------------------------------------------------------------------+
+
+ use mod_oasis
+ use mar_module
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_ra
+ use mar_lb
+ use mar_dy
+ use mar_hy
+ use mar_te
+ use mar_tu
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use mar_sl
+ use mar_ao
+ use mar_tv
+ use mar_bs
+ use marssn
+ use mar_io
+ use marsib
+ use mar_po
+ use mar_wk
+
+ implicit none
+
+ ! +--MAR Variables
+ ! + ----------------
+
+ integer i, j, k, m, n, isl
+
+ ! AO_CK 20/02/2020
+
+ ! +--cpl : GET FIELDS FROM OASIS
+ ! + ===========================
+ ! write(6, *) "get fields?", tocken_AO
+ if(tocken_AO == 1) then
+ ! fromcpl a deja ete appele pour ce pas de temps
+ tocken_AO = 0
+ else
+ ! il_time_secs : temps du run en sec. au pas de temps precedant
+ il_time_secs = iterun * idt
+ ! write(*,*) ' call fromcpl, itexpe =', itexpe
+
+ ! + *******
+ call fromcpl(il_time_secs, srftAO(:, :, 1), aoss, &
+ sicsAO, aogla, albAO(:, :, 2), aoalb, srftAO(:, :, 2), aotic, &
+ hicAO, aohic, hsnoAO, aohsn, UoceAO, ao_uo, VoceAO, ao_vo, &
+ UiceAO, ao_ui, ViceAO, ao_vi)
+ ! + *******
+
+ ! cpl----those oceanic fields from oasis are used along the code--
+
+ ! +--open water albedo (same parametrisation as in NEMO,
+ ! + ----------------- but with a real zenith angle)
+
+ ! see Briegleb & Ramanathan, JAM, 1982
+ ! print *, aoss, il_time_secs,iterun !for debug
+ do i = 1, mx
+ do j = 1, my
+
+ ! Albedo from the ocean as computed in NEMO
+ ! czenGE=cos(zenith angle),cld_SL=cloud cover
+ albAO(i, j, 1) = (0.05 / (1.1 * czenGE(i, j)**1.4 + 0.15)) * cld_SL(i, j) &
+ + 0.06 * (1.-cld_SL(i, j))
+
+ ! you should avoid coupling sst and sic on different time steps
+ ! even if it's possible in the code with different aoss and aogla
+ if(aoss > 0 .and. weightao_sst(i, j) /= 1) then
+
+ ! avoid interpolation error in oasis
+ !WARNING WARNING WARNING
+ srftAO(i, j, 1) = min(max(srftAO(i, j, 1) / (1 - sicsAO(i, j)), 271.01), 300.15)
+
+ sst_LB(i, j) = (1.-weightao_sst(i, j)) * srftAO(i, j, 1) &
+ + (weightAO_sst(i, j) * sst_LB(i, j))
+ endif
+
+ !+update of new snow layers in phy_sisvat_mp.f
+ if(aotic > 0 .and. weightao_st(i, j) /= 1) then
+ !avoid interpolation error in oasis (non interecative mask)
+ !WARNING WARNING WARNING
+ srftAO(i, j, 2) = min(max(srftAO(i, j, 2) / sicsAO(i, j), 250.001), 273.15)
+
+ if(sicsAO(i, j) > 0) then
+ do isl = 1, nsno
+ if(maskSL(i, j) == 1 .and. nssSNo(i, j, 2) >= 1) then
+ ! if there was snow/sea ice at dt-1 on sea(maskSL=1)
+ tisSNo(i, j, 2, isl) = (1.-weightao_st(i, j)) * srftAO(i, j, 2) &
+ + weightAO_st(i, j) * tisSNo(i, j, 2, isl)
+ endif
+ enddo
+ endif
+
+ endif
+
+ if(aogla > 0 .and. weightAO_sic(i, j) /= 1) then
+ sicsIB(i, j) = (1.-weightao_sic(i, j)) * sicsAO(i, j) &
+ + (weightAO_sic(i, j) * sicsIB(i, j))
+ endif
+
+ if(aoalb > 0) then
+ albAO(i, j, 2) = max(min(albAO(i, j, 2) / sicsAO(i, j), 1.0), 0.0)
+ ! weighting directly in snoptp.f (phy_sisvat => (sisvat) => snoptp)
+ endif
+
+ enddo
+ enddo
+
+ ! hicAO et hsnoAO => only in full NEMO domain (update in physisvat_mp)
+
+ endif
+
+ return
+end
diff --git a/MAR/code_mar/out_nc.f90 b/MAR/code_mar/out_nc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..44bb56ec783936d7d48a397a04717581710c3e89
--- /dev/null
+++ b/MAR/code_mar/out_nc.f90
@@ -0,0 +1,1047 @@
+#include "MAR_pp.def"
+subroutine out_nc(ipr_nc)
+ ! +------------------------------------------------------------------------+
+ ! | MAR OUTPUT Fri 20-Jan-2012 MAR |
+ ! | subroutine out_nc is used to write the main Model Variables |
+ ! | on a NetCDF file |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: ipr_nc: Current time step number |
+ ! | ^^^^^^ (starting from ipr_nc=1, which => new file creation) |
+ ! | |
+ ! | OUTPUT: NetCDF File adapted to IDL Graphic Software |
+ ! | ^^^^^^ |
+ ! | |
+ ! | CAUTION: This Routine requires the usual NetCDF library, |
+ ! | ^^^^^^^^ and the complementary access library 'libUN.a' |
+ ! | |
+ ! | MODIF. 4 Nov 2009 : OUTPUT of Map Scaling Factor SFm_DY |
+ ! | ^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_te
+ use mar_tu
+ use mar_ca
+ use mar_hy
+ use mar_ra
+ use mar_sl
+ use mar_sv
+ use mardSV
+ use mar_TV
+ use marsSN
+ use mar_wk
+ use mar_io
+ use trackwind, only : track_wind, ntrackwind, delta_u, delta_v, itw, &
+ name_wind, delta_u_NCsave, delta_v_NCsave, ddelta_var, &
+ track_dgz, ntrackdgz, delta_u_dgz, delta_v_dgz, &
+ name_dgz, delta_u_dgz_NCsave, delta_v_dgz_NCsave
+ use trackwater, only: jtw, track_water, delta_qv, ntwater, &
+ name_water, delta_qv_NCsave, ddelta_water
+
+ implicit none
+
+ integer, intent(in) :: ipr_nc
+ integer i, j, k, m
+ real Soilz(mz)
+ common / out_nc_rea / Soilz
+
+ integer nsnomz, kk
+ parameter(nsnomz=min(nsno, mz))
+
+ integer kOUTnc, nOUTnc
+ integer ijSNOW(mx, my)
+ common / out_nc_int / kOUTnc, nOUTnc, ijSNOW
+
+ ! +--Local Variables
+ ! + ================
+
+#if(IZ)
+ logical noZOOM
+#endif
+ logical LastIO
+ real end_YR
+
+ integer Lfnam, Ltit, Luni, Lnam, Llnam
+ PARAMETER(Lfnam=40, Ltit=90, Luni=90, Lnam=13, Llnam=50)
+ ! +...Length of char strings
+
+ character * (Lfnam) fnamNC
+ common / out_nc_loc / fnamNC
+ ! +... fnamNC: To retain file name.
+
+ integer NdimNC
+ PARAMETER(NdimNC=6)
+ ! +...Number of defined spatial dimensions (exact)
+
+ integer MXdim
+ PARAMETER(MXdim=86401)
+ ! +...Maximum Number of all dims: recorded Time Steps
+ ! + and also maximum of spatial grid points for each direction.
+
+ integer MX_var
+ PARAMETER(MX_var=120)
+ ! +...Maximum Number of Variables
+
+ integer NattNC
+ PARAMETER(NattNC=2)
+ ! +...Number of real attributes given to all variables
+
+ integer RCODE
+
+ integer njmo
+ integer jourNC(MXdim)
+ integer moisNC(MXdim)
+ real yearNC(MXdim)
+ real dateNC(MXdim)
+ common / out_nc_r / yearNC, dateNC
+ real timeNC(MXdim)
+ real VALdim(MXdim, 0:NdimNC)
+ integer nDFdim(0:NdimNC)
+ common / out_nc_i / nDFdim
+ integer NvatNC(NattNC)
+ character * (Lnam) NAMdim(0:NdimNC)
+ character * (Luni) UNIdim(0:NdimNC)
+ character * (Lnam) SdimNC(4, MX_var)
+ character * (Luni) unitNC(MX_var)
+ character * (Lnam) nameNC(MX_var)
+ character * (Llnam) lnamNC(MX_var)
+ character * (Ltit) tit_NC
+ character * (Lnam) NAMrat(NattNC)
+#if(TC)
+ character * 9 labelc
+#endif
+ character * 120 tmpINP
+
+ integer n1000, n100a, n100, n10_a, n10, n1, m10
+ integer n, l, jd10, jd1, MMXstp
+ integer it, mois, mill, iu, itotNC, NtotNC, ID__nc
+#if(TC)
+ integer itot
+#endif
+ real starti, starta(1), DayLen, rhodzk
+
+ character * 1 chn
+ character * 7 lab__z, lab_dz, lab_ro, lab_wa, lab_g1, lab_g2, lab_Ti
+
+ data lab__z/'z_mmWE '/
+ data lab_dz/'dzSNOW '/
+ data lab_ro/'roSNOW '/
+ data lab_wa/'waSNOW '/
+ data lab_g1/'g1SNOW '/
+ data lab_g2/'g2SNOW '/
+ data lab_Ti/'TiSNOW '/
+
+#if(IZ)
+ data noZOOM/.false./
+#endif
+
+ ! +--NetCDF File Initialization
+ ! + ==========================
+
+ if(ipr_nc == 1) then
+
+ ! +--Nb of OUTPUT per File (Option #SO for splitting the MAR*.nc file)
+ ! + ---------------------
+
+ nOUTnc = npr_nc
+#if(SO)
+ nOUTnc = (2.0 / 0.09) * (161.*161.*34.) / (mx * my * mzz)
+ kOUTnc = 86400.1 / (dt * nboucl)
+ nOUTnc = nOUTnc / kOUTnc
+ nOUTnc = nOUTnc * kOUTnc
+ nOUTnc = min(nOUTnc, &
+ kOUTnc * (365 + max(0, 1 - mod(iyrrGE, 4))))
+ if(npr_nc == nprint + 1) then
+ nOUTnc = nOUTnc + 1
+ endif
+ nOUTnc = min(npr_nc, nOUTnc)
+#endif
+ npr_nc = npr_nc - nOUTnc
+
+ n1000 = 1 + iyrrGE / 1000
+ n100a = mod(iyrrGE, 1000)
+ n100 = 1 + n100a / 100
+ n10_a = mod(n100a, 100)
+ n10 = 1 + n10_a / 10
+ n1 = 1 + mod(n10_a, 10)
+ m10 = 1 + mmarGE / 10
+ m1 = 1 + mod(mmarGE, 10)
+ jd10 = 1 + jdarGE / 10
+ jd1 = 1 + mod(jdarGE, 10)
+
+ ! +--Output File Label
+ ! + -----------------
+
+ fnamNC = 'MAR.' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1) &
+ //'.'//explIO &
+ //'.nc '
+
+#if(SO)
+ write(6, 6000) fnamNC, nOUTnc, npr_nc, kOUTnc
+6000 format(/, '++++++++++++++++++++++++++++++++++++++++++++++', &
+ /, 'out_nc: Nb of OUTPUT: ', a19, ':', i4, &
+ /, ' After present File:', i4, &
+ /, ' Per Day :', i4, &
+ /, '++++++++++++++++++++++++++++++++++++++++++++++')
+#endif
+
+ ! +--Output Title
+ ! + ------------
+
+ tit_NC = 'MAR' &
+ //' - Exp: '//explIO &
+ //' - ' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1)
+
+ ! +--Create File / Write Constants
+ ! + -----------------------------
+
+ MMXstp = MXdim
+ ! +...To check array bounds... silently
+
+ ! +--Time Variable (hour)
+ ! + ~~~~~~~~~~~~~~~~~~~~
+
+ ! +... To define a NetCDF dimension (size, name, unit):
+ nDFdim(0) = nOUTnc
+ nDFdim(0) = 0
+ NAMdim(0) = 'time'
+ UNIdim(0) = 'HOURS since 1901-01-15 00:00:00'
+
+ ! +... Check temporary arrays: large enough ?
+ if(nOUTnc > MMXstp) &
+ STOP '*** out_nc - ERROR : MXdim to low ***'
+
+ starti = jhurGE + minuGE / 60.d0 + jsecGE / 3600.d0
+ ! +... starti : Starting Time (= current time in the day)
+ ! Nb Days before iyrrGE
+ ! Nb Leap Years
+ ! Nb Days before mmarGE
+ ! (including Leap Day)
+ starta(1) = (351 + (iyrrGE - 1902) * 365 &
+ + (iyrrGE - 1901) / 4 &
+ + njyrGE(mmarGE) &
+ + njybGE(mmarGE) &
+ * max(0, 1 - mod(iyrrGE, 4)) &
+ + jdarGE - 1) * 24 &
+ + jhurGE &
+ + (minuGE * 60 + jsecGE) / 3600.
+
+ do it = 1, nOUTnc
+ timeNC(it) = starti + (it - 1) * nboucl * dt / 3600.
+ ! +... nboucl: #iter between output
+
+ VALdim(it, 0) = starta(1) + (it - 1) * nboucl * dt / 3600.
+ ! +... VALdim( ,0) : values of the dimension # 0 (time)
+
+ ! +--Time Variable (date)
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ dateNC(it) = timeNC(it)
+ jourNC(it) = jdarGE + timeNC(it) / 24.
+ enddo
+ mois = mmarGE
+ mill = iyrrGE
+ do it = 1, nOUTnc
+ if(mois == 2 .and. &
+ mod(mill, 4) == 0) then
+ njmo = njmoGE(mois) + 1
+ else
+ njmo = njmoGE(mois)
+ endif
+ if(jourNC(it) > njmo) then
+ do iu = it, nOUTnc
+ jourNC(iu) = jourNC(iu) - njmo
+ enddo
+ mois = mois + 1
+ if(mois > 12) then
+ mois = 1
+ mill = mill + 1
+ endif
+ endif
+ moisNC(it) = mois
+ yearNC(it) = mill
+
+ if(dateNC(it) > 24.-epsi) then
+ DayLen = 24.
+ do iu = it, nOUTnc
+ dateNC(iu) = mod(dateNC(iu), DayLen)
+ enddo
+ endif
+ enddo
+
+ do it = 1, nOUTnc
+ dateNC(it) = dateNC(it) &
+ + 1.d+2 * jourNC(it) &
+ + 1.d+4 * moisNC(it)
+ enddo
+
+ ! +--Define horizontal spatial dimensions :
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! +...Check temporary arrays: large enough ?
+ if(mx > MMXstp .or. my > MMXstp &
+ .or. mzz > MMXstp .or. mw > MMXstp) &
+ STOP '*** out_nc - ERROR : MXdim to low ***'
+
+ ! +...To define NetCDF dimensions (size, name, unit):
+
+ do i = 1, mx
+ VALdim(i, 1) = xxkm(i)
+ enddo
+ nDFdim(1) = mx
+ NAMdim(1) = 'x'
+ UNIdim(1) = 'km'
+
+ do j = 1, my
+ VALdim(j, 2) = yykm(j)
+ enddo
+ nDFdim(2) = my
+ NAMdim(2) = 'y'
+ UNIdim(2) = 'km'
+
+ do k = 1, mz
+ VALdim(k, 3) = sigma(k)
+ enddo
+ nDFdim(3) = mz
+ NAMdim(3) = 'level'
+ UNIdim(3) = 'sigma_level'
+ ! +... For levels k
+
+ do k = 1, mz
+ VALdim(k, 4) = sigmid(k + 1)
+ enddo
+ nDFdim(4) = mz
+ NAMdim(4) = 'level2'
+ UNIdim(4) = 'sigma_level'
+ ! +... For levels k+1/2
+
+ do k = 1, mz
+ VALdim(k, 5) = sigma(k)
+ enddo
+ VALdim(mzz, 5) = 1.
+ nDFdim(5) = mzz
+ NAMdim(5) = 'levelp1'
+ UNIdim(5) = 'sigma_level'
+ ! +... For levels mzz
+
+ do k = 1, mw
+ VALdim(k, 6) = k
+ enddo
+ nDFdim(6) = mw
+ NAMdim(6) = 'sector'
+ UNIdim(6) = 'level'
+ ! +... For Surface Sectors
+
+ ! +--Variable's Choice (Table MARvou.dat)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ OPEN(unit=10, status='unknown', file='MARvou.dat')
+
+ itotNC = 0
+980 continue
+ READ(10, '(A120)', end=990) tmpINP
+ if(tmpINP(1:4) == ' ') then
+ itotNC = itotNC + 1
+ READ(tmpINP, '(4x,5A9,A12,A50)') &
+ nameNC(itotNC), SdimNC(1, itotNC), SdimNC(2, itotNC), &
+ SdimNC(3, itotNC), SdimNC(4, itotNC), &
+ unitNC(itotNC), lnamNC(itotNC)
+#if(TC)
+ ! +... nameNC: Name
+ ! + SdimNC: Names of Selected Dimensions (max.4/variable)
+ ! + unitNC: Units
+ ! + lnamNC: Long_name, a description of the variable
+ if(nameNC(itotNC) == 'qxTC ' .and. nkWri >= 1) then
+ nameNC(itotNC) = namTC(1)
+ if(nkWri > 1) then
+ itot = itotNC
+ do n = 2, nkWri
+ itot = itot + 1
+ nameNC(itot) = namTC(n)
+ do m = 1, 4
+ SdimNC(m, itot) = SdimNC(m, itotNC)
+ enddo
+ unitNC(itot) = unitNC(itotNC)
+ lnamNC(itot) = lnamNC(itotNC)
+ enddo
+ itotNC = itot
+ endif
+ endif
+#endif
+
+ endif
+ GOTO 980
+990 continue
+
+ CLOSE(unit=10)
+
+ NtotNC = itotNC
+ ! +... NtotNC : Total number of variables writen in NetCDF file.
+
+ ! +--List of NetCDF attributes given to all variables:
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! +... The "actual_range" is the (min,max)
+ ! + of all data for each variable:
+ NAMrat(1) = 'actual_range'
+ NvatNC(1) = 2
+
+ ! +... The "[var]_range" is NOT of attribute type,
+ ! + it is a true variable containing the (min,max) for
+ ! + each level, for 4D (space+time) variables only
+ ! + (automatic handling by UN library;
+ ! + must be the LAST attribute)
+ NAMrat(NattNC) = '[var]_range'
+ NvatNC(NattNC) = 2
+
+ ! +--Automatic Generation of the NetCDF File Structure
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! + **************
+ call UNscreate(fnamNC, tit_NC, &
+ NdimNC, nDFdim, MXdim, NAMdim, UNIdim, VALdim, &
+ MX_var, NtotNC, nameNC, SdimNC, unitNC, lnamNC, &
+ NattNC, NAMrat, NvatNC, &
+ ID__nc)
+ ! + **************
+
+ ! +--Write Time - Constants
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = GElonh(i, j) * 15.
+ ! +... Conversion: Hour->degrees
+
+ WKxy2(i, j) = GElatr(i, j) / degrad
+ ! +... Conversion: rad ->degrees
+
+ WKxy3(i, j) = isolSL(i, j)
+ ! +... Conversion to REAL type (integer not allowed)
+
+ WKxy4(i, j) = isolTV(i, j)
+ ! +... Conversion to REAL type (integer not allowed)
+
+ enddo
+ enddo
+
+ do l = 1, llx
+ Soilz(l) = -deptTV(l)
+ enddo
+ do l = llx + 1, mz
+ Soilz(l) = -deptTV(llx) - 1.e-6 * (l - llx)
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc, 'lon ', 1, mx, my, 1, WKxy1)
+ call UNwrite(ID__nc, 'lat ', 1, mx, my, 1, WKxy2)
+ call UNwrite(ID__nc, 'MapSC ', 1, mx, my, 1, SFm_DY)
+ call UNwrite(ID__nc, 'sh ', 1, mx, my, 1, sh)
+ call UNwrite(ID__nc, 'isol ', 1, mx, my, 1, WKxy3)
+ call UNwrite(ID__nc, 'TEX ', 1, mx, my, 1, WKxy4)
+ call UNwrite(ID__nc, 'DepthS ', ipr_nc, mz, 1, 1, Soilz)
+ call UNwrite(ID__nc, 'dsigm1', 1, mz, 1, 1, dsigm1)
+
+ ! + ************
+
+ ! +--Snow Mosa?c for OUTPUT
+ ! + ======================
+
+ do j = 1, my
+ do i = 1, mx
+ ijSNOW(i, j) = 1 + maskSL(i, j)
+ enddo
+ enddo
+
+ if(track_wind) then
+ ! initialize track momentum budget
+ delta_u_NCsave = 0.
+ delta_v_NCsave = 0.
+ ! ddelta_var = delta_var - delta_var_NCsave
+ ddelta_var = 0.
+ endif
+
+ else
+ ! +--Re-Open file if already created.
+ ! + ================================
+
+ ! + ************
+ call UNwopen(fnamNC, ID__nc)
+ ! + ************
+
+ endif
+
+ ! +--Write Time-dependent variables:
+ ! + ===============================
+
+ ! +--UNLIMITED Time Dimension
+ ! + ------------------------
+
+ if(nDFdim(0) == 0) then
+ ! Nb Days before iyrrGE
+ ! Nb Leap Years
+ ! Nb Days before mmarGE
+ ! (including Leap Day)
+ starta(1) = (351 + (iyrrGE - 1902) * 365 &
+ + (iyrrGE - 1901) / 4 &
+ + njyrGE(mmarGE) &
+ + njybGE(mmarGE) &
+ * max(0, 1 - mod(iyrrGE, 4)) &
+ + jdarGE - 1) * 24 &
+ + jhurGE &
+ + (minuGE * 60 + jsecGE) / 3600.
+
+ ! + ************
+ call UNwrite(ID__nc, 'time ', ipr_nc, 1, 1, 1, starta(1))
+ ! + ************
+
+ endif
+
+ ! + ************
+ call UNwrite(ID__nc, 'date ', ipr_nc, 1, 1, 1, dateNC(ipr_nc))
+ call UNwrite(ID__nc, 'year ', ipr_nc, 1, 1, 1, yearNC(ipr_nc))
+ ! + ************
+
+ ! +--Geopotential Height, Saturation Specific Humidity
+ ! + -------------------------------------------------
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = gplvDY(i, j, k) * grvinv
+ WKxyz2(i, j, k) = qvswDY(i, j, k)
+#if(NH)
+ WKxyz3(i, j, k) = pairNH(i, j, k) * pstDYn(i, j) * sigma(k)
+#endif
+ WKxyz4(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+
+ ! +--Surface Humidity and Green Leaf Fraction [%]
+ ! + --------------------------------------------
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ enddo
+ enddo
+
+ do n = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = WKxy1(i, j) &
+ + eta_TV(i, j, n, 1) * SLsrfl(i, j, n)
+ WKxy2(i, j) = WKxy2(i, j) &
+ + glf_TV(i, j, n) * alaiTV(i, j, n) * SLsrfl(i, j, n)
+ enddo
+ enddo
+ enddo
+
+ do l = 1, llx
+ do n = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+ WKxyz4(i, j, l) = WKxyz4(i, j, l) &
+ + eta_TV(i, j, n, l) * SLsrfl(i, j, n)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do l = 1, llx
+ do j = 1, my
+ do i = 1, mx
+ WKxy3(i, j) = WKxy3(i, j) &
+ + WKxyz4(i, j, l) * dz_dSV(1 - l)
+ enddo
+ enddo
+ enddo
+
+ if(track_wind) then
+ ! track momentum budget
+ ! ---------------------
+ do itw = 1, ntrackwind
+ ! delta u
+ ddelta_var = delta_u(:, :, :, itw) - delta_u_NCsave(:, :, :, itw)
+ call UNwrite (ID__nc, 'du_' // name_wind(itw), ipr_nc, mx, my, mz, ddelta_var)
+ ! delta v
+ ddelta_var = delta_v(:, :, :, itw) - delta_v_NCsave(:, :, :, itw)
+ call UNwrite (ID__nc, 'dv_' // name_wind(itw), ipr_nc, mx, my, mz, ddelta_var)
+ enddo
+ delta_u_NCsave = delta_u
+ delta_v_NCsave = delta_v
+ endif
+ if (track_dgz) then
+ ! track momentum budget in dyndgz
+ ! -------------------------------
+ do itw = 1, ntrackdgz
+ ! delta u dgz
+ ddelta_var = delta_u_dgz(:, :, :, itw) - delta_u_dgz_NCsave(:, :, :, itw)
+ call UNwrite (ID__nc, 'du_' // name_dgz(itw), ipr_nc, mx, my, mz, ddelta_var)
+ ! delta v dgz
+ ddelta_var = delta_v_dgz(:, :, :, itw) - delta_v_dgz_NCsave(:, :, :, itw)
+ call UNwrite (ID__nc, 'dv_' // name_dgz(itw), ipr_nc, mx, my, mz, ddelta_var)
+ enddo
+ delta_u_dgz_NCsave = delta_u_dgz
+ delta_v_dgz_NCsave = delta_v_dgz
+ end if
+
+ if(track_water) then
+ ! track water budget
+ ! ------------------
+ do jtw = 1, ntwater
+ ! delta qv
+ ddelta_water = delta_qv(:, :, :, jtw) - delta_qv_NCsave(:, :, :, jtw)
+ call UNwrite(ID__nc, 'dq_' // name_water(jtw), ipr_nc, mx, my, mz, ddelta_water)
+ enddo
+ delta_qv_NCsave = delta_qv
+ endif
+
+ ! + ************
+ call UNwrite(ID__nc, 'uairDY ', ipr_nc, mx, my, mz, uairDY)
+ call UNwrite(ID__nc, 'vairDY ', ipr_nc, mx, my, mz, vairDY)
+ call UNwrite(ID__nc, 'wairDY ', ipr_nc, mx, my, mz, wairDY)
+ call UNwrite (ID__nc, 'psigDY ', ipr_nc, mx, my, mz, psigDY)
+ call UNwrite (ID__nc, 'wsigDY ', ipr_nc, mx, my, mz, wsigDY)
+ call UNwrite(ID__nc, 'tairDY ', ipr_nc, mx, my, mz, tairDY)
+ call UNwrite(ID__nc, 'pktaDY ', ipr_nc, mx, my, mzz, pktaDY)
+#if(NH)
+ call UNwrite(ID__nc, 'wairNH ', ipr_nc, mx, my, mz, wairNH)
+ call UNwrite(ID__nc, 'pairNH ', ipr_nc, mx, my, mz, WKxyz3)
+#endif
+ call UNwrite(ID__nc, 'qvDY ', ipr_nc, mx, my, mz, qvDY)
+ call UNwrite(ID__nc, 'zzDY ', ipr_nc, mx, my, mz, WKxyz1)
+ call UNwrite(ID__nc, 'qsatDY ', ipr_nc, mx, my, mz, WKxyz2)
+ call UNwrite(ID__nc, 'pstDY ', ipr_nc, mx, my, 1, pstDY)
+ call UNwrite(ID__nc, 'RadOLR ', ipr_nc, mx, my, 1, RAdOLR)
+ call UNwrite(ID__nc, 'RadSol ', ipr_nc, mx, my, 1, RAdsol)
+ call UNwrite(ID__nc, 'Rad_IR ', ipr_nc, mx, my, 1, RAD_ir)
+ call UNwrite(ID__nc, 'hmelSL ', ipr_nc, mx, my, 1, hmelSL)
+ call UNwrite(ID__nc, 'tairSL ', ipr_nc, mx, my, 1, TairSL)
+ call UNwrite(ID__nc, 'tsrfSL ', ipr_nc, mx, my, mw, tsrfSL)
+#if(T2)
+ call UNwrite(ID__nc, 'Ta2mSL ', ipr_nc, mx, my, mw, Ta2mSL)
+ call UNwrite(ID__nc, 'TminSL ', ipr_nc, mx, my, mw, TminSL)
+ call UNwrite(ID__nc, 'TmaxSL ', ipr_nc, mx, my, mw, TmaxSL)
+ call UNwrite(ID__nc, 'Ta3mSL ', ipr_nc, mx, my, mw, Ta3mSL)
+ call UNwrite(ID__nc, 'V03mSL ', ipr_nc, mx, my, mw, V03mSL)
+ call UNwrite(ID__nc, 'V10mSL ', ipr_nc, mx, my, mw, V10mSL)
+#endif
+ call UNwrite(ID__nc, 'albxSL ', ipr_nc, mx, my, mw, albxSL)
+ call UNwrite(ID__nc, 'hsenSL ', ipr_nc, mx, my, 1, hsenSL)
+ call UNwrite(ID__nc, 'hlatSL ', ipr_nc, mx, my, 1, hlatSL)
+ call UNwrite(ID__nc, 'ect_TE ', ipr_nc, mx, my, mz, ect_TE)
+ call UNwrite(ID__nc, 'eps_TE ', ipr_nc, mx, my, mz, eps_TE)
+ call UNwrite(ID__nc, 'TUkvm ', ipr_nc, mx, my, mz, TUkvm)
+ call UNwrite(ID__nc, 'TUkvh ', ipr_nc, mx, my, mz, TUkvh)
+ call UNwrite(ID__nc, 'SL_z0 ', ipr_nc, mx, my, mw, SL_z0)
+ call UNwrite(ID__nc, 'SL_r0 ', ipr_nc, mx, my, mw, SL_r0)
+#if(BS)
+ call UNwrite(ID__nc, 'ustart ', ipr_nc, mx, my, mw, SaltSN)
+ call UNwrite(ID__nc, 'z0emBS ', ipr_nc, mx, my, mw, Z0emBS)
+ call UNwrite(ID__nc, 'z0SaBS ', ipr_nc, mx, my, mw, Z0SaBS)
+#endif
+ call UNwrite(ID__nc, 'SLsrfl ', ipr_nc, mx, my, mw, SLsrfl)
+ call UNwrite(ID__nc, 'SLuusl ', ipr_nc, mx, my, mw, SLuusl)
+ call UNwrite(ID__nc, 'SLutsl ', ipr_nc, mx, my, mw, SLutsl)
+ call UNwrite(ID__nc, 'SLuqsl ', ipr_nc, mx, my, mw, SLuqsl)
+ call UNwrite(ID__nc, 'SLussl ', ipr_nc, mx, my, mw, SLussl)
+ call UNwrite(ID__nc, 'albeSL ', ipr_nc, mx, my, 1, albeSL)
+ call UNwrite(ID__nc, 'Clouds ', ipr_nc, mx, my, 1, cld_SL)
+ ! + ************
+
+ ! + ************
+ call UNwrite(ID__nc, 'HumSol ', ipr_nc, mx, my, 1, WKxy1)
+ call UNwrite(ID__nc, 'GreenL ', ipr_nc, mx, my, 1, WKxy2)
+ call UNwrite(ID__nc, 'WatSol ', ipr_nc, mx, my, 1, WKxy3)
+ call UNwrite(ID__nc, 'EvapoT ', ipr_nc, mx, my, 1, evapTV)
+ call UNwrite(ID__nc, 'Draing ', ipr_nc, mx, my, 1, draiTV)
+ call UNwrite(ID__nc, 'RunOFF ', ipr_nc, mx, my, 1, runoTV)
+ call UNwrite(ID__nc, 'H2OSol ', ipr_nc, mx, my, mz, WKxyz4)
+ ! + ************
+
+#if(IZ)
+ if(noZOOM) then
+#endif
+#if(DY)
+ ! +--Dynamical Budget
+ ! + ----------------
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ dumy3D(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+ ! + ******
+ call dynbil(7, 1, ipr_nc, ID__nc, 0., 0., 0., 0., dumy3D)
+ ! + ******
+#endif
+#if(IZ)
+ endif
+#endif
+
+ ! +--Cloud Microphysics, Mass Flux convective Scheme
+ ! + -----------------------------------------------
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qwHY(i, j, k) + qiHY(i, j, k)
+ WKxyz2(i, j, k) = qrHY(i, j, k) + qsHY(i, j, k)
+ WKxyz3(i, j, k) = dqv_CA(i, j, k) * Lv_H2O / cp &
+ * min(adj_CA(i, j), iun) * 86400./dt_Loc
+ WKxyz4(i, j, k) = (dpktCA(i, j, k) &
+ * (ptopDY + sigma(k) * pstDY(i, j))**cap) &
+ * min(adj_CA(i, j), iun) * 86400./dt_Loc
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ zcd_HY(i, j) = zcd_HY(i, j) / max(eps9, Hcd_HY(i, j)) / gravit
+ Tcd_HY(i, j) = Tcd_HY(i, j) / max(eps9, Hcd_HY(i, j))
+ zsb_HY(i, j) = zsb_HY(i, j) / max(eps9, Hsb_HY(i, j)) / gravit
+ Tsb_HY(i, j) = Tsb_HY(i, j) / max(eps9, Hsb_HY(i, j))
+ Hcd_HY(i, j) = Hcd_HY(i, j) / max(1, icntHY)
+ Hsb_HY(i, j) = Hsb_HY(i, j) / max(1, icntHY)
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc, 'QwQi ', ipr_nc, mx, my, mz, WKxyz1)
+ call UNwrite(ID__nc, 'QrQs ', ipr_nc, mx, my, mz, WKxyz2)
+ call UNwrite(ID__nc, 'ccniHY ', ipr_nc, mx, my, mz, ccniHY)
+ call UNwrite(ID__nc, 'qiHY ', ipr_nc, mx, my, mz, qiHY)
+ call UNwrite(ID__nc, 'qwHY ', ipr_nc, mx, my, mz, qwHY)
+ call UNwrite(ID__nc, 'qsHY ', ipr_nc, mx, my, mz, qsHY)
+ call UNwrite(ID__nc, 'qrHY ', ipr_nc, mx, my, mz, qrHY)
+ call UNwrite(ID__nc, 'hlatHY ', ipr_nc, mx, my, mz, hlatHY)
+ call UNwrite(ID__nc, 'HLCond ', ipr_nc, mx, my, 1, Hcd_HY)
+ call UNwrite(ID__nc, 'TaCond ', ipr_nc, mx, my, 1, Tcd_HY)
+ call UNwrite(ID__nc, 'z_Cond ', ipr_nc, mx, my, 1, zcd_HY)
+ call UNwrite(ID__nc, 'HLSubl ', ipr_nc, mx, my, 1, Hsb_HY)
+ call UNwrite(ID__nc, 'TaSubl ', ipr_nc, mx, my, 1, Tsb_HY)
+ call UNwrite(ID__nc, 'z_Subl ', ipr_nc, mx, my, 1, zsb_HY)
+ call UNwrite(ID__nc, 'rainHY ', ipr_nc, mx, my, 1, rainHY)
+ call UNwrite(ID__nc, 'snowHY ', ipr_nc, mx, my, 1, snowHY)
+ call UNwrite(ID__nc, 'crysHY ', ipr_nc, mx, my, 1, crysHY)
+ ! + ************
+
+ icntHY = 0
+ do j = 1, my
+ do i = 1, mx
+ Hcd_HY(i, j) = 0.
+ Tcd_HY(i, j) = 0.
+ zcd_HY(i, j) = 0.
+ Hsb_HY(i, j) = 0.
+ Tsb_HY(i, j) = 0.
+ zsb_HY(i, j) = 0.
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc, 'CAPE ', ipr_nc, mx, my, 1, capeCA)
+ call UNwrite(ID__nc, 'rainCA ', ipr_nc, mx, my, 1, rainCA)
+ call UNwrite(ID__nc, 'snowCA ', ipr_nc, mx, my, 1, snowCA)
+ call UNwrite(ID__nc, 'dqv_CA ', ipr_nc, mx, my, mz, WKxyz3)
+ call UNwrite(ID__nc, 'dpktCA ', ipr_nc, mx, my, mz, WKxyz4)
+ ! + ************
+
+#if(WB)
+ ! +--Water Budget
+ ! + ------------
+ ! + ******
+ call H2O_WB(-1, 0., 0., .false., .true.)
+ ! + ******
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = dq__WB(i, j, 1)
+ WKxy2(i, j) = dq__WB(i, j, 2)
+ WKxy3(i, j) = dq__WB(i, j, 3)
+ WKxy4(i, j) = dq__WB(i, j, 4)
+ WKxy5(i, j) = dq__WB(i, j, 5)
+ WKxy6(i, j) = dq__WB(i, j, 6)
+ enddo
+ enddo
+ call UNwrite(ID__nc, 'H2O_ADV', ipr_nc, mx, my, 1, WKxy1)
+ call UNwrite(ID__nc, 'H2OdifH', ipr_nc, mx, my, 1, WKxy2)
+ call UNwrite(ID__nc, 'H2O_CVA', ipr_nc, mx, my, 1, WKxy3)
+ call UNwrite(ID__nc, 'H2OdifV', ipr_nc, mx, my, 1, WKxy4)
+ call UNwrite(ID__nc, 'H2O_mic', ipr_nc, mx, my, 1, WKxy5)
+ call UNwrite(ID__nc, 'H2Ofltr', ipr_nc, mx, my, 1, WKxy6)
+ call UNwrite(ID__nc, 'H2OsrfT', ipr_nc, mx, my, 1, uq__WB)
+ call UNwrite(ID__nc, 'H2OsrfA', ipr_nc, mx, my, 1, wq__WB)
+ call UNwrite(ID__nc, 'H2Oflux', ipr_nc, mx, my, 1, upq_WB)
+ call UNwrite(ID__nc, 'H2Ofluy', ipr_nc, mx, my, 1, vpq_WB)
+ call UNwrite(ID__nc, 'H2Omean', ipr_nc, mx, my, 1, cpq_WB)
+ call UNwrite(ID__nc, 'Snoflux', ipr_nc, mx, my, 1, ups_WB)
+ call UNwrite(ID__nc, 'Snofluy', ipr_nc, mx, my, 1, vps_WB)
+ call UNwrite(ID__nc, 'Snomean', ipr_nc, mx, my, 1, cps_WB)
+ call UNwrite(ID__nc, 'Vap_Liq', ipr_nc, mx, my, mz, dqwHY)
+ call UNwrite(ID__nc, 'Vap_Ice', ipr_nc, mx, my, mz, dqiHY)
+ ! + ******
+ call H2O_WB(-1, 0., 0., .true., .false.)
+ ! + ******
+#endif
+
+#if(OD)
+ ! +--Cloud Optical Depth
+ ! + -------------------
+ do j = 1, my
+ do i = 1, mx
+ ! +... WKxy1(i,j) : liquid water path (kg/m2) (droplets)
+ WKxy1(i, j) = 0.
+ ! +... WKxy2(i,j) : liquid water path (kg/m2) (crystals)
+ WKxy2(i, j) = 0.
+ enddo
+ enddo
+ do k = mzabso + 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ! rhodzk : (rho / 1000) * (dz * gravit)
+ rhodzk = (pstDY(i, j) * sigma(k) + ptopDY) &
+ / (ra * tairDY(i, j, k) * (1.+.608 * qvDY(i, j, k))) &
+ * (gpmiDY(i, j, k) - gpmiDY(i, j, k + 1))
+ WKxy1(i, j) = WKxy1(i, j) + rhodzk * qwHY(i, j, k)
+ WKxy2(i, j) = WKxy2(i, j) + rhodzk * qiHY(i, j, k)
+ enddo
+ enddo
+ enddo
+ do j = 1, my
+ do i = 1, mx
+ WKxy3(i, j) = 1.5 * (WKxy1(i, j) / 20.d-6 &
+ + WKxy2(i, j) / 40.d-6) * grvinv
+ enddo
+ enddo
+ call UNwrite(ID__nc, 'OptDep ', ipr_nc, mx, my, 1, WKxy3)
+#endif
+
+ ! + ************
+ call UNwrite(ID__nc, 'OptDep ', ipr_nc, mx, my, 1, RAcdtO)
+ ! + ************
+
+ ! +--Snow Pack
+ ! + ---------
+
+ if(SnoMod .and. VSISVAT) then
+
+ do k = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ WRKxys(i, j, k) = zWE_SN(i, j, k) - zWE0SN(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ do n = 1, mw
+
+ if(n > 1) then
+ lab__z(5:5) = '_'
+ lab_dz(5:5) = '_'
+ lab_ro(5:5) = '_'
+ lab_wa(5:5) = '_'
+ lab_g1(5:5) = '_'
+ lab_g2(5:5) = '_'
+ lab_Ti(5:5) = '_'
+ write(chn, '(i1)') n
+ lab__z(6:6) = chn
+ lab_dz(6:6) = chn
+ lab_ro(6:6) = chn
+ lab_wa(6:6) = chn
+ lab_g1(6:6) = chn
+ lab_g2(6:6) = chn
+ lab_Ti(6:6) = chn
+ else
+ lab__z(5:6) = 'WE'
+ lab_dz(5:6) = 'OW'
+ lab_ro(5:6) = 'OW'
+ lab_wa(5:6) = 'OW'
+ lab_g1(5:6) = 'OW'
+ lab_g2(5:6) = 'OW'
+ lab_Ti(5:6) = 'OW'
+ endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.
+ WKxyz2(i, j, k) = 0.
+ WKxyz3(i, j, k) = 0.
+ WKxyz4(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ do k = 1, nsnomz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz4(i, j, k) = min(max(nssSNo(i, j, n) - k + 1, 0), 1) ! 0: outside SnowPack
+ enddo
+ enddo
+ enddo
+
+ do k = 1, nsnomz
+ do j = 1, my
+ do i = 1, mx
+#if(vS)
+ n = ijSNOW(i, j) ! 1: Land / 2:Ocean
+#endif
+ kk = max(nssSNo(i, j, n) - k + 1, 1) ! 1: 1st lev SnowPack
+
+ WKxyz1(i, j, k) = dzsSNo(i, j, n, kk) * WKxyz4(i, j, k) &
+ + epsi * (1.-WKxyz4(i, j, k))
+ WKxyz2(i, j, k) = rosSNo(i, j, n, kk) * WKxyz4(i, j, k)
+ WKxyz3(i, j, k) = wasSNo(i, j, n, kk) * WKxyz4(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc, lab__z, ipr_nc, mx, my, mw, WRKxys)
+ call UNwrite(ID__nc, lab_dz, ipr_nc, mx, my, mz, WKxyz1)
+ call UNwrite(ID__nc, lab_ro, ipr_nc, mx, my, mz, WKxyz2)
+ call UNwrite(ID__nc, lab_wa, ipr_nc, mx, my, mz, WKxyz3)
+ ! + ************
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.
+ WKxyz2(i, j, k) = 0.
+ WKxyz3(i, j, k) = 0.
+ WKxyz4(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ do k = 1, nsnomz
+ do j = 1, my
+ do i = 1, mx
+ kk = max(nssSNo(i, j, n) - k + 1, 1) ! 1: 1st lev SnowPack
+ WKxyz1(i, j, k) = g1sSNo(i, j, n, kk) * WKxyz4(i, j, k)
+ WKxyz2(i, j, k) = g2sSNo(i, j, n, kk) * WKxyz4(i, j, k)
+ WKxyz3(i, j, k) = tisSNo(i, j, n, kk) * WKxyz4(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc, lab_g1, ipr_nc, mx, my, mz, WKxyz1)
+ call UNwrite(ID__nc, lab_g2, ipr_nc, mx, my, mz, WKxyz2)
+ call UNwrite(ID__nc, lab_Ti, ipr_nc, mx, my, mz, WKxyz3)
+ ! + ************
+
+ enddo
+
+ endif
+
+#if(PO)
+ ! +--Polynya
+ ! + -------
+ ! + ************
+ call UNwrite(ID__nc, 'hatmPO ', ipr_nc, mx, my, 1, hatmPO)
+ call UNwrite(ID__nc, 'hfraPO ', ipr_nc, mx, my, 1, hfraPO)
+ call UNwrite(ID__nc, 'aicePO ', ipr_nc, mx, my, 1, aicePO)
+ call UNwrite(ID__nc, 'hicePO ', ipr_nc, mx, my, 1, hicePO)
+ call UNwrite(ID__nc, 'hiavPO ', ipr_nc, mx, my, 1, hiavPO)
+ ! + ************
+#endif
+
+#if(TC)
+ ! +--Chemical Species
+ ! + ----------------
+ if(nkWri > 0) then
+ do n = 1, nkWri
+ labelc = namTC(ikTC(n))
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ ! +... Conversion [kg/kg] ------------------> [micro-g/kg]
+ ! Conversion [mcm] ------------------> [ppb] if requested
+ WKxyz1(i, j, k) = qxTC(i, j, k, ikTC(n)) * 1.000d+09
+#endif
+#if(CH)
+ ! =>Conversion [kg/kg] ------------------> [micro-g/kg] eliminated
+ ! ==> 0.392D-19 = 392D-10/1.d+9
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * rolvDY(i, j, k) * 0.392D-19 / Unity
+#endif
+#if(TC)
+ enddo
+ enddo
+ enddo
+ ! + ************
+ call UNwrite(ID__nc, labelc(1:7), ipr_nc, mx, my, mz, WKxyz1)
+ ! + ************
+ enddo
+ endif
+#endif
+
+ ! +--That 's all, folks: NetCDF File Closure
+ ! + =======================================
+
+ ! + ************
+ call UNclose(ID__nc)
+ ! + ************
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ WKxy4(i, j) = 0.0
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+
+ if(mmarGE == 12 .and. jdarGE == 31) then
+ end_YR = real(24 - jhurGE) * 3599.9 - dt * nboucl
+ if(end_YR < 0.) then
+ LastIO = .true.
+ else
+ LastIO = .false.
+ endif
+ else
+ if(mmarGE == 1 .and. jdarGE == 1 .and. jhurGE == 0 .and. &
+ iyrrGE > iyr0GE .and. &
+ iterun >= nboucl * nprint) then
+ LastIO = .true.
+ else
+ LastIO = .false.
+ endif
+ endif
+
+ ! + +++++++++++
+ ! + if (LastIO) ipr_nc = 0 ! ipr_nc:=0 => NEW MAR*.nc created
+ ! + +++++++++++ ! at the next out_nc call
+
+ return
+endsubroutine out_nc
diff --git a/MAR/code_mar/outgks.f90 b/MAR/code_mar/outgks.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ffe5193656d4b5534fcc43e071b7abced5f08646
--- /dev/null
+++ b/MAR/code_mar/outgks.f90
@@ -0,0 +1,263 @@
+#include "MAR_pp.def"
+subroutine OUTgks
+ ! +
+ ! +------------------------------------------------------------------------+
+ ! | MAR OUTPUT 19-09-2001 MAR |
+ ! | subroutine OUTgks is used to write the main Model Variables |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | OUTPUT: on asci file si_ddhhmm.LAB (Atmospheric Dynamics, Surface) |
+ ! | ^^^^^^ cl_ddhhmm.LAB (Microphysics) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use marsnd
+ use mar_dy
+ use mar_te
+ use mar_tu
+ use mar_hy
+ use mar_sl
+ use mar_sv
+ use mar_io
+#if(OL)
+ use mar_OL
+#endif
+#if(PO)
+ use mar_po
+#endif
+ ! +
+ implicit none
+ ! +
+ external zext
+ integer zext
+ ! +
+ ! +
+ ! +--Local Variables
+ ! + ================
+ ! +
+ integer i, j, k, m
+ real fac_sh
+ integer jmmd, jm10, jh10, jh1, jd10, jd1
+ ! +
+ ! +
+ ! +--Linear Mountain Waves Characteristics
+ ! + =====================================
+ ! +
+#if(OL)
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ urefOL(i, j, k) = uairDY(i, j, k)
+ uairDY(i, j, k) = (uairDY(i, j, k) - ugeoDY(i, j, k)) * 1000.d0
+ trefOL(i, j, k) = tairDY(i, j, k)
+ tairDY(i, j, k) = (tairDY(i, j, k) - tSND(1, 1)) * 1000.d0 &
+ + tSND(1, 1)
+ gplvOL(i, j, k) = gplvDY(i, j, k)
+ gplvDY(i, j, k) = (gplvDY(i, j, k) - gp00OL(i, j, k)) * 1000.d0 &
+ + gp00OL(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+ fac_sh = 1.d0
+#if(OL)
+ fac_sh = 1.d3
+#endif
+ ! +
+ ! +
+ ! +--Output File Label
+ ! + =================
+ ! +
+ fnam(1:3) = 'si_'
+ jmmd = 1 + mod(minuGE, 10)
+ jm10 = 1 + minuGE / 10
+ jh10 = 1 + jhaMAR / 10
+ jh1 = 1 + mod(jhaMAR, 10)
+ jd10 = 1 + jdaMAR / 10
+ jd1 = 1 + mod(jdaMAR, 10)
+ if(jd10 > 10) then
+ fnam(3:3) = '+'
+ jd10 = mod(jd10, 10)
+ endif
+ fnam(4:4) = labnum(jd10)
+ fnam(5:5) = labnum(jd1)
+ fnam(6:6) = labnum(jh10)
+ fnam(7:7) = labnum(jh1)
+ fnam(8:8) = labnum(jm10)
+ fnam(9:9) = labnum(jmmd)
+ fnam(10:10) = '.'
+ fnam(11:13) = explIO
+ fnam(14:16) = ' '
+ ! +
+ ! +
+ ! +--File si_ddhhmm.LAB (Atmospheric Dynamics, Surface)
+ ! + ==================================================
+ ! +
+ open(unit=13, status='unknown', file=fnam)
+ rewind 13
+ ! +
+ write(13, 613) itexpe, iterun, imez, jmez
+613 format(4i12)
+ write(13, 611) qsolSL
+611 format(l2, ' qsolSL')
+ write(13, 614)(((fac_sh * sh(i, j)), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+614 format(10e12.5, ' sh')
+ write(13, 615) GElat0, GElon0, itizGE(imez, jmez), fcorDY(imez, jmez), &
+ 0.1d0 * pSND(1, 1), pstSND, &
+ GEddxx, zs_SL, zn_SL, zl_SL, dt, dx, ptopDY
+615 format(6e12.5)
+ write(13, 616)(sigma(k), k=mzw1IO, mzw2IO, izw_IO)
+616 format(8f12.8, ' s')
+ write(13, 617)(ugeoDY(1, 1, k), k=mzw1IO, mzw2IO, izw_IO)
+617 format(8e12.5, ' ug')
+ write(13, 618)(vgeoDY(1, 1, k), k=mzw1IO, mzw2IO, izw_IO)
+618 format(8e12.5, ' vg')
+ ! +
+ write(13, 619) itexpe * dt, jdaMAR, jhaMAR, &
+ mmarGE, jdarGE, jhurGE, minuGE, jsecGE
+619 format(e12.5, 2i12, ' time - jdaMAR - jhaMAR', &
+ i5, '/', i2, i3, 'h', i2, 'm', i2, 's')
+ write(13, 620)(((uairDY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+620 format(10f12.6, ' u')
+ write(13, 621)(((vairDY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+621 format(10f12.6, ' v')
+ write(13, 622)((((wairDY(i, j, k)), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+622 format(10e12.5, ' w')
+ write(13, 623)((((tairDY(i, j, k)), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+623 format(10f12.6, ' T')
+ write(13, 624)((((gplvDY(i, j, k) * grvinv), &
+ i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+624 format(10f12.4, ' GPlev')
+ write(13, 625)(((qvDY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+625 format(10e12.5, ' qv ')
+ write(13, 627)((hmelSL(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+627 format(10e12.5, ' hmel')
+ write(13, 628)((pstDY(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+628 format(10f12.6, ' pstar')
+ write(13, 629)((tsrfSL(i, j, 1), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+629 format(10f12.6, ' tsrfSL')
+ write(13, 630)(((TUkvm(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+630 format(10f12.6, ' TUkvm')
+ write(13, 631)(((TUkvh(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+631 format(10f12.6, ' TUkvh')
+ write(13, 632)((SLuus(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+632 format(10f12.6, ' SLuus')
+ write(13, 633)((SLuts(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+633 format(10f12.6, ' SLuts')
+ write(13, 634)((SLuqs(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+634 format(10f12.9, ' SLuqs')
+ ! +
+ write(13, 636)(((ect_TE(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+636 format(10e12.5, ' ect_TE')
+ ! +
+#if(PO)
+ write(13, 6370)((hatmPO(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+6370 format(10f12.2, ' H(atm) ')
+ write(13, 637)((hfraPO(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+637 format(10f12.6, ' Frazil')
+ write(13, 6380)((SLsrfl(i, j, 2), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+6380 format(10f12.6, ' Srf Wa ')
+ write(13, 6381)((aicePO(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+6381 format(10f12.6, ' A(ice) ')
+ write(13, 6382)((hicePO(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+6382 format(10f12.6, ' h(ice) ')
+ write(13, 6383)((hiavPO(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+6383 format(10f12.6, ' Hi avr.')
+#endif
+ ! +
+ close(unit=13)
+ ! +
+ ! +
+ ! +--File cl_ddhhmm.LAB (Microphysics)
+ ! + =================================
+ ! +
+ fnam(1:2) = 'cl'
+ open(unit=14, status='unknown', file=fnam)
+ rewind 14
+ ! +
+ write(14, 641) - zext(turnHY), itexpe, jdarGE, jhurGE
+641 format(4i12, ' turnHY - itexpe - jdarGE - jhurGE')
+ write(14, 642)(((qwHY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+642 format(10e12.5, ' qw')
+ write(14, 643)(((qiHY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+643 format(10e12.5, ' qi')
+ write(14, 644)(((qrHY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+644 format(10e12.5, ' qr')
+ write(14, 645)(((qsHY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+645 format(10e12.5, ' qs')
+ write(14, 646)((rainHY(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+646 format(10e12.5, ' rain')
+ write(14, 647)((snowHY(i, j), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO)
+647 format(10e12.5, ' snow')
+ write(14, 648)(((hlatHY(i, j, k), i=mxw1IO, mxw2IO, ixw_IO), &
+ j=myw1IO, myw2IO, iyw_IO), &
+ k=mzw1IO, mzw2IO, izw_IO)
+648 format(10e12.5, ' hlat')
+ ! +
+ close(unit=14)
+ ! +
+ ! +
+ ! +--RESET
+ ! + =====
+ ! +
+#if(OL)
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ uairDY(i, j, k) = urefOL(i, j, k)
+ tairDY(i, j, k) = trefOL(i, j, k)
+ gplvDY(i, j, k) = gplvOL(i, j, k)
+ enddo
+ enddo
+ enddo
+#endif
+ ! +
+ return
+endsubroutine OUTgks
diff --git a/MAR/code_mar/outice.f90 b/MAR/code_mar/outice.f90
new file mode 100644
index 0000000000000000000000000000000000000000..22680c1b77f48903fe54bd48848cb7eb2039539e
--- /dev/null
+++ b/MAR/code_mar/outice.f90
@@ -0,0 +1,3273 @@
+subroutine OUTice
+ ! +------------------------------------------------------------------------+
+ ! | MAR OUTPUT 28-11-2022 MAR |
+ ! | subroutine OUTice is used to initialize |
+ ! | and perform Ouput of Surface Mass Balance |
+ ! | (Netcdf files) |
+ ! | |
+ ! | CAUTION: the Estimation of the Optical Depth codIB is obsolescent |
+ ! | ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_ra
+ use mar_sl
+ use mar_sv
+ use mar_tv
+ use mar_hy
+ use mar_ca
+ use marssn
+ use mar_ib
+ use marsib
+ use mar_wk
+ use mar_io
+ use mardsv
+ use mar_te
+ use mar_ao
+ use mar0sv
+ use trackwind, only: track_wind, itw, ntrackwind, delta_u, delta_v, &
+ name_wind, duIB, dvIB, delta_u_IBsave, delta_v_IBsave, &
+ track_dgz, ntrackdgz, delta_u_dgz, delta_v_dgz, &
+ name_dgz, dudgzIB, dvdgzIB, delta_u_dgz_IBsave, delta_v_dgz_IBsave
+ use trackwater, only: jtw, track_water, ntwater, delta_qv, &
+ name_water, dqvIB, delta_qv_IBsave
+
+ implicit none
+
+ INCLUDE 'NetCDF.inc'
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer Lfnam, Ltit, Luni, Lnam, Llnam
+ PARAMETER(Lfnam=40, Ltit=90, Luni=90, Lnam=13, Llnam=50)
+ ! +...Length of char strings
+
+ integer NdimNC_ice
+ PARAMETER(NdimNC_ice=12)
+ ! +...Number of defined spatial dimensions (exact)
+
+ integer MXdim
+ PARAMETER(MXdim=20000)
+ ! +...Maximum Number of all dims: recorded Time Steps
+ ! + and also maximum of spatial grid points for each direction.
+
+ integer MX_var
+ PARAMETER(MX_var=200)
+ ! +...Maximum Number of Variables
+ ! +
+ integer NattNC_ice
+ PARAMETER(NattNC_ice=1)
+ ! +...Number of real attributes given to all variables
+
+ real yearNC_ice(MXdim)
+ real dateNC_ice(MXdim)
+ real timeNC_ice(MXdim)
+ real VALdim(MXdim, 0:NdimNC_ice)
+ real tmp(3), tmp1z(mz), tmp2z(mz), tmp3, tmp4
+ real znsn1(nsno + 1), znsn2(nsno + 1), snwae(nsno + 1)
+ real tmp1_OK, tmp2_OK, tmp3_OK, avlwc, factim
+
+ real, allocatable :: xyllx1(:, :, :)
+ real, allocatable :: xyllx2(:, :, :)
+ real, allocatable :: xyllx3(:, :, :)
+ real, allocatable :: xyllx4(:, :, :)
+ real, allocatable :: xymi1(:, :, :)
+ real, allocatable :: xymi2(:, :, :)
+ real, allocatable :: xymi3(:, :, :)
+ real, allocatable :: xymi4(:, :, :)
+ real, allocatable :: xymi5(:, :, :)
+ real, allocatable :: xymi6(:, :, :)
+ real, allocatable :: xymi7(:, :, :)
+ real, allocatable :: xynsno1(:, :, :)
+ real, allocatable :: xynsno2(:, :, :)
+ real, allocatable :: xynsno3(:, :, :)
+ real, allocatable :: xynsno4(:, :, :)
+ real, allocatable :: xynsno5(:, :, :)
+ real, allocatable :: xynsno6(:, :, :)
+ real, allocatable :: xynsno7(:, :, :)
+ real, allocatable :: xynsno8(:, :, :)
+ real, allocatable :: xynsx0(:, :, :)
+ real, allocatable :: xynsx1(:, :, :)
+ real, allocatable :: xynsx2(:, :, :)
+ real, allocatable :: xynsx3(:, :, :)
+ real, allocatable :: xynsx4(:, :, :)
+ real, allocatable :: xynsx5(:, :, :)
+ real, allocatable :: xynsx6(:, :, :)
+ real, allocatable :: xynsx7(:, :, :)
+ real, allocatable :: xymlhh(:, :, :)
+ real, allocatable :: xynsx8(:, :, :)
+ real, allocatable :: xynsx9(:, :, :)
+ real, allocatable :: xynsx10(:, :, :)
+ real, allocatable :: xynsx11(:, :, :)
+ real, allocatable :: xynsx12(:, :, :)
+ real, allocatable :: xynsx13(:, :, :)
+ real, allocatable :: xynsx14(:, :, :)
+
+ real depthsnow(nsno), depthSNo, dater
+ real pLev, pUp, pDown, pMiddle, distUp
+ real zLev, zUp, zDown, zMiddle
+ real q, qst, r, rst, rh, qsat0D,rh1,rh2
+ real rhodz, phi, cphi, sphi
+
+ integer nDFdim(0:NdimNC_ice)
+ integer NvatNC_ice(NattNC_ice)
+ integer dayNC_ice(MXdim)
+ integer monthNC_ice(MXdim), RCODE
+ integer n1000, n100a, n100, n10_a, n10, n1, m10
+ integer n, jd10, jd1, nk, kk, nx
+ integer it, month, mill, iu
+ integer iSBLmx(mz), jSBLmx(mz)
+ integer ID__nc_ice, itotNC_ice, NtotNC_ice
+ integer dt_ICE, nbr_dt_ICE, dt_ICE2, index, njmo
+ integer kp, kz, kUp, kDown, kMiddle, OutdyIB0
+
+ character * (Lfnam) fnamNC_ice, fnamNC_ics, fnamNC_tmp
+ character * (Lnam) NAMdim(0:NdimNC_ice)
+ character * (Luni) UNIdim(0:NdimNC_ice)
+ character * (Lnam) SdimNC_ice(4, MX_var)
+ character * (Luni) unitNC_ice(MX_var)
+ character * (Lnam) nameNC_ice(MX_var)
+ character * (Llnam) lnamNC_ice(MX_var)
+ character * (Ltit) tit_NC_ice
+ character * (Lnam) NAMrat(NattNC_ice)
+ character * 120 tmpINP
+ character * 1 sector
+ integer(kind=8) date, date0
+ integer iyrrIB, mmarIB, jdarIB, jhurIB, minuIB
+
+ common / OUTice_r / yearNC_ice, dateNC_ice
+ common / OUTice_i / dt_ICE, dt_ICE2, nDFdim, OutdyIB0, &
+ iyrrIB, mmarIB, jdarIB, jhurIB, minuIB
+ common / OUTice_i8 / date, date0
+ common / OUTice_c / fnamNC_ice, fnamNC_ics
+
+ real rhh, num, den
+ integer i_hi, i_lo
+ real(kind=8) refrac_h, refrac_w
+ real p_hi, p_lo, z_hi, z_lo, kappa
+
+ real, parameter :: k1p = 7.76e-7
+ real, parameter :: k2p = 3.73e-3
+ real, parameter :: Md = 28.9644
+ real, parameter :: Mv = 18.0153
+ real, parameter :: E = Mv / Md
+
+ ! ! for having a ICS*.nc file with snapshots
+ ! ! when ICE*.nc is written
+
+ logical, parameter :: snapshot = .false.
+ integer :: ss
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++ 1. Initialisation ++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ allocate(xyllx1(mx, my, llx))
+ allocate(xyllx2(mx, my, llx))
+ allocate(xyllx3(mx, my, llx))
+ allocate(xyllx4(mx, my, llx))
+ allocate(xymi1(mx, my, mi))
+ allocate(xymi2(mx, my, mi))
+ allocate(xymi3(mx, my, mi))
+ allocate(xymi4(mx, my, mi))
+ allocate(xymi5(mx, my, mi))
+ allocate(xymi6(mx, my, mi))
+ allocate(xymi7(mx, my, mi))
+ allocate(xynsno1(mx, my, nsno))
+ allocate(xynsno2(mx, my, nsno))
+ allocate(xynsno3(mx, my, nsno))
+ allocate(xynsno4(mx, my, nsno))
+ allocate(xynsno5(mx, my, nsno))
+ allocate(xynsno6(mx, my, nsno))
+ allocate(xynsno7(mx, my, nsno))
+ allocate(xynsno8(mx, my, nsno))
+ allocate(xynsx0(mx, my, nsx))
+ allocate(xynsx1(mx, my, nsx))
+ allocate(xynsx2(mx, my, nsx))
+ allocate(xynsx3(mx, my, nsx))
+ allocate(xynsx4(mx, my, nsx))
+ allocate(xynsx5(mx, my, nsx))
+ allocate(xynsx6(mx, my, nsx))
+ allocate(xynsx7(mx, my, nsx))
+ allocate(xymlhh(mx, my, mlhh))
+ allocate(xynsx8(mx, my, nsx))
+ allocate(xynsx9(mx, my, nsx))
+ allocate(xynsx10(mx, my, nsx))
+ allocate(xynsx11(mx, my, nsx))
+ allocate(xynsx12(mx, my, nsx))
+ allocate(xynsx13(mx, my, nsx))
+ allocate(xynsx14(mx, my, nsx))
+
+ ID__nc_ice = -1 ! NetCDF File is not open
+
+ if(itexpe <= 1) then
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ wei0IB(i, j, k) = 0. ! Bottom Ice added
+ wee_IB(i, j, k, :) = 0. ! Evapo/Sublimation
+ wem_IB(i, j, k) = 0. ! Melting
+ wer_IB(i, j, k) = 0. ! Refreezing
+ weu_IB(i, j, k) = 0. ! Run-off
+ weo_IB(i, j, k, :) = 0. ! Run-off
+ weacIB(i, j, k) = 0.
+ weerIB(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+ endif
+
+ if(iterun <= 1) then
+ ! +--1.1 Initialization of all variables
+ ! + ===================================
+ ss = 0
+ if(snapshot) ss = 1
+800 continue
+
+ itrdIB = 0
+ dt_ICE2 = 0
+ timehIB = 0.
+ OutdyIB0 = min(1, max(0, OutdyIB - 1))
+ iyrrIB = 0
+
+ do j = 1, my
+ do i = 1, mx
+ werr0IB(i, j) = 0. ! max(0.,rainHY(i,j))
+ wesf0IB(i, j) = 0. ! max(0.,snowHY(i,j))
+ wecp0IB(i, j) = 0. ! max(0.,rainCA(i,j)+snowCA(i,j))
+ wero0IB(i, j) = max(0., runoTV(i, j))
+ WKxy2(i, j) = 0.
+ do n = 1, nsx
+ WKxy2(i, j) = WKxy2(i, j) &
+ + SLsrfl(i, j, n) * snohSN(i, j, n) / 1000.
+ weh0IB(i, j, n) = 0.
+ enddo
+ ! wesf0IB(i, j) = wesf0IB(i, j) ! - WKxy2(i,j) no bluffer
+ prh0IB(i, j) = 0.
+ meh0IB(i, j) = 0.
+ suh0IB(i, j) = 0.
+ snfh0IB(i, j) = 0.
+ cph0IB(i, j) = 0.
+ ruh0IB(i, j) = 0.
+ swdIB(i, j) = 0. ! Shortwave incoming Radiation
+ swuIB(i, j) = 0. ! Shortwave outgoing Radiation
+ lwdIB(i, j) = 0. ! Longwave incoming Radiation
+ lwuIB(i, j) = 0. ! Longwave outgoing Radiation
+ swdtIB(i, j) = 0. ! TOA Shortwave incoming Radiation
+ swutIB(i, j) = 0. ! TOA Shortwave outgoing Radiation
+ lwutIB(i, j) = 0. ! TOA Longwave outgoing Radiation
+ sunIB(i, j) = 0. ! Sunshine
+ shfIB(i, j) = 0. ! Sensible Heat
+ lhfIB(i, j) = 0. ! Latent Heat
+ alIB(i, j) = 0. ! Albedo
+ as1_IB(i, j) = 0. ! Albedo
+ as2_IB(i, j) = 0. ! Albedo
+ as3_IB(i, j) = 0. ! Albedo
+ sicIB(i, j) = 0. ! Sea ice fraction
+ stIB(i, j) = 0. ! Surface Temperature
+ spIB(i, j) = 0. ! Surface Pressure
+ slpIB(i, j) = 0. ! Sea Surface Pressure
+ if(mw == 5) then
+ gradTIB(i, j) = 0. ! *CL* Local temp. gradient
+ gradQIB(i, j) = 0. ! *CL* Local hum. gradient
+ endif
+ ccIB(i, j) = 0. ! Cloud Cover
+ cuIB(i, j) = 0. ! Cloud Cover
+ cmIB(i, j) = 0. ! Cloud Cover
+ cdIB(i, j) = 0. ! Cloud Cover
+ codIB(i, j) = 0. ! Cloud Optical Depth
+ qwIB(i, j) = 0. ! Cloud Dropplets Concent
+ qiIB(i, j) = 0. ! Cloud Ice Crystals Concent.
+ qsIB(i, j) = 0. ! Cloud Snow Flakes Concent.
+ qrIB(i, j) = 0. ! Cloud Rain Concentration
+ wvpIB(i, j) = 0. ! Water Vapour Path / cCA old
+ cwpIB(i, j) = 0. ! Condensed Water Path / cCA old
+ iwpIB(i, j) = 0. ! Ice Water Path / cCA old
+ tcwvIB(i, j) = 0. ! Total column water vapor / cCA new
+ tclcIB(i, j) = 0. ! Total column liquid cloud / cCA new
+ tcicIB(i, j) = 0. ! Total column ice cloud / cCA new
+ tclpIB(i, j) = 0. ! Total column liquid precipitation / cCA new
+ tcipIB(i, j) = 0. ! Total column ice precipitation / cCA new
+ qbrIB(i, j) = 0. ! Snow ratio between kb level and surface
+ sicaoIB(i, j) = 0. ! SIC from OASIS
+ sitaoIB(i, j) = 0. !sea ice thickness
+ sntaoIB(i, j) = 0. !snow on sea ice thickness
+ if(mw == 5) then
+ mingrTIB(i, j) = 5. ! *CL* Maximum temp gradient the Day
+ maxgrTIB(i, j) = -5. ! *CL* Maximum temp gradient of the Day
+ mingrQIB(i, j) = 100. ! *CL* Maximum spec hum gradient the Day
+ maxgrQIB(i, j) = -100.! *CL* Maximum spec hum gradient of the Day
+ endif
+ pddIB(i, j) = 0. ! Positive degree day quantity
+ enddo
+ enddo
+
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ ! wet_IB : Total Mass Balance
+ wet_IB(i, j, k) = 0.
+ ! wec0IB : canopy water content
+ wec0IB(i, j, k) = CaWaTV(i, j, k)
+ ! wel0IB : soil water content
+ wel0IB(i, j, k) = 0.
+ ! wee_IB : Evapo/Subli
+ wee_IB(i, j, k, :) = 0.
+ wee0IB(i, j, k, :) = 0.
+ ! wem_IB : onlyMelting
+ wem_IB(i, j, k) = 0.
+ wem0IB(i, j, k) = 0.
+ ! weu_IB : run-off
+ weu_IB(i, j, k) = 0.
+ ! weo_IB : run-off
+ weo_IB(i, j, k, :) = 0.
+ weu0IB(i, j, k) = 0.
+ weo0IB(i, j, k, :) = 0.
+ ! wer_IB : Refreezing
+ wer_IB(i, j, k) = 0.
+ wer0IB(i, j, k) = 0.
+ wesw0IB(i, j, k) = max(0., SWaSNo(i, j, k))
+ do kk = 1, ml
+ enddo
+ weacIB(i, j, k) = 0.
+ weerIB(i, j, k) = 0.
+ weac0IB(i, j, k) = 0.
+ weer0IB(i, j, k) = 0.
+ if(mw == 5) then
+ tt_intIB(i, j, k) = 0. !*CL* Interpolated temperature
+ qq_intIB(i, j, k) = 0. !*CL* Interpolated spec. hum.
+ endif
+ al1IB(i, j, k) = 0. ! Albedo
+ al2IB(i, j, k) = 0. ! Albedo
+ frvIB(i, j, k) = 0. ! ifratv
+ st2IB(i, j, k) = 0. ! Surface Temperature
+ z0IB(i, j, k) = 0. ! Roughness length for Moment.
+ r0IB(i, j, k) = 0. ! Roughness length for Heat
+ uusIB(i, j, k) = 0. ! Friction Velocity
+ uusthIB(i, j, k) = 0. ! Threshold Friction Velocity
+ utsIB(i, j, k) = 0. ! Sfc Pot. Tp. Turb. Flux
+ uqsIB(i, j, k) = 0. ! Water Vapor Flux
+ ussIB(i, j, k) = 0. ! Blowing Snow Flux
+ pblIB(i, j, k) = 0. ! Height of Boundary Layer (2)
+ zn4IB(i, j, k) = 0. ! snowheight change due to compaction
+ zn5IB(i, j, k) = 0. ! snowheight change due to melting
+ zn6IB(i, j, k) = 0. ! snowheight total
+ ! output from coupling
+ st2aoIB(i, j, k) = 0. !surface temperature from OASIS
+ albaoIB(i, j, k) = 0. !albedo from OASIS
+ txhIB0(i, j) = -99. ! Maximum Temp of the hour
+ tnhIB0(i, j) = 99. ! Minimum Temp of the hour
+ enddo
+ enddo
+ enddo
+
+ do kk = 1, ml
+ do j = 1, my
+ do i = 1, mx
+ snf0IB(i, j, kk) = 0. ! atmospheric snowfall
+ sbl0IB(i, j, kk) = 0. ! atmospheric snowfall sublimation
+ qssbl0IB(i, j, kk) = 0. ! atmospehric sublimation ratio
+ dep0IB(i, j, kk) = 0. ! atmospheric snowfall condensation
+ rnf0IB(i, j, kk) = 0. ! atmospheric rainfall
+ evp0IB(i, j, kk) = 0. ! atmospheric rainfall evaporation
+ smt0IB(i, j, kk) = 0. ! int. snow mass transport
+ snf_IB(i, j, kk) = 0. ! atmospheric snowfall
+ sbl_IB(i, j, kk) = 0. ! atmospheric snowfall sublimation
+ qssbl_IB(i, j, kk) = 0. ! atmospheric sublimation ratio
+ dep_IB(i, j, kk) = 0. ! atmospheric snowfall condensation
+ rnf_IB(i, j, kk) = 0. ! atmospheric rainfall
+ evp_IB(i, j, kk) = 0. ! atmospheric rainfall evaporation
+ smt_IB(i, j, kk) = 0. ! integrated snow mass transport
+ mintIB(i, j, kk) = 99. ! Minimum Temp of the Day
+ maxtIB(i, j, kk) = -99. ! Maximum Temp of the Day
+ maxwIB(i, j, kk) = 0. ! Maximum wind of the Day
+ ttIB(i, j, kk) = 0. ! Temperature
+ tdIB(i, j, kk) = 0. ! Temperature
+ uuIB(i, j, kk) = 0. ! x-Wind Speed component
+ vvIB(i, j, kk) = 0. ! y-Wind Speed component
+ if(track_wind) then
+ do itw = 1, ntrackwind
+ duIB(i, j, kk, itw) = 0. ! delta_u in m s-2
+ dvIB(i, j, kk, itw) = 0. ! delta_v in m s-2
+ enddo
+ endif
+ if(track_dgz) then
+ do itw = 1, ntrackdgz
+ dudgzIB(i, j, kk, itw) = 0. ! delta_u_dgz in m s-2
+ dvdgzIB(i, j, kk, itw) = 0. ! delta_v_dgz in m s-2
+ enddo
+ endif
+ wwIB(i, j, kk) = 0. ! z-Wind Speed component
+ psigIB(i, j, kk) = 0. ! psigDY : p* X Vertical Wind Speed (in sigma coordinate) (kPa/s)
+ wsigIB(i, j, kk) = 0. ! wsigDY : Vertical Wind Speed (in sigma coordinate) (1/s)
+ uvIB(i, j, kk) = 0. ! Horizontal Wind Speed
+ ruuIB(i, j, kk) = 0. ! x-Wind Speed component (reg grid)
+ rvvIB(i, j, kk) = 0. ! y-Wind Speed component (reg grid)
+ ruvIB(i, j, kk) = 0. ! Horizontal Wind Speed (reg grid)
+ qqIB(i, j, kk) = 0. ! Specific Humidity
+ if(track_water) then
+ do jtw = 1, ntwater
+ dqvIB(i, j, kk, jtw) = 0. ! delta_qv in (g/kg) / hour
+ enddo
+ endif
+ rhodzIB(i, j, kk) = 0. ! rho x dz = dsigma x SP / g
+ rolvIB(i, j, kk) = 0. ! Air Density
+ rhIB(i, j, kk) = 0. ! Relative Humidity
+ zzIB(i, j, kk) = 0. ! Model Levels Height
+ tkeIB(i, j, kk) = 0. ! TKE
+ lqsIB(i, j, kk) = 0. ! Snow flakes content at first levels
+ lqiIB(i, j, kk) = 0. ! Ice flakes content at first levels
+ lqwIB(i, j, kk) = 0. ! Water flakes content at first levels
+ lqrIB(i, j, kk) = 0. ! Rain flakes content at first levels
+ qsbIB(i, j, kk) = 0. ! Sublimation of Qs
+ lsbIB(i, j, kk) = 0. ! Total Vertical Integration of LH (k=1) + LH
+ swn3DIB(i, j, kk) = 0. ! SW net per atm. level
+ lwn3DIB(i, j, kk) = 0. ! LW net per atm. level
+ swnc3DIB(i, j, kk) = 0.! Clear-sky SW net per atm. level
+ lwnc3DIB(i, j, kk) = 0.! Clear-sky LW net per atm. level
+ cod3DIB(i, j, kk) = 0. ! Cloud Optical Depth per atm. level
+ cc3DIB(i, j, kk) = 0. ! Cloud Cover per atm. level
+ ! tnh(i, j, kk) = tnhIB0(i, j)
+ ! txh(i, j, kk) = txhIB0(i, j)
+ enddo
+ enddo
+ enddo
+
+ do kp = 1, mp
+ do j = 1, my
+ do i = 1, mx
+ nbpIB(i, j, kp) = 0 ! Count valid data on pressure levels
+ ttpIB(i, j, kp) = 0. ! Temperature
+ uupIB(i, j, kp) = 0. ! x-Wind Speed component
+ vvpIB(i, j, kp) = 0. ! y-Wind Speed component
+ wwpIB(i, j, kp) = 0. ! w-Wind Speed component
+ uvpIB(i, j, kp) = 0. ! Horizontal Wind Speed
+ qqpIB(i, j, kp) = 0. ! Specific Humidity
+ zzpIB(i, j, kp) = 0. ! Model Levels Height
+ enddo
+ enddo
+ enddo
+
+ do kz = 1, mztq
+ do j = 1, my
+ do i = 1, mx
+ ttzIB(i, j, kz) = 0. ! Temperature
+ qqzIB(i, j, kz) = 0. ! Specific Humidity
+ enddo
+ enddo
+ enddo
+
+ do kz = 1, mzuv
+ do j = 1, my
+ do i = 1, mx
+ uuzIB(i, j, kz) = 0. ! x-Wind Speed component
+ vvzIB(i, j, kz) = 0. ! y-Wind Speed component
+ u2zIB(i, j, kz) = 0. ! x-Wind Speed component
+ v2zIB(i, j, kz) = 0. ! y-Wind Speed component
+ uvzIB(i, j, kz) = 0. ! Horizontal Wind Speed
+ rozIB(i, j, kz) = 0. ! Air density
+ enddo
+ enddo
+ enddo
+
+ do kk = 1, llx
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ sltIB(i, j, k, kk) = 0 ! Soil Temperature
+ slqIB(i, j, k, kk) = 0 ! Soil Humidity Content
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do kk = 1, mi
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ agIB(i, j, k, kk) = 0. ! Average ag
+ g1IB(i, j, k, kk) = 0. ! Average g1
+ g2IB(i, j, k, kk) = 0. ! Average g2
+ roIB(i, j, k, kk) = 0. ! Average ro
+ tiIB(i, j, k, kk) = 0. ! Average ti
+ waIB(i, j, k, kk) = 0. ! Avegage wa
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! +--1.2 Output Netcdf Initialisation
+ ! + ================================
+
+ n1000 = 1 + iyrrGE / 1000
+ n100a = mod(iyrrGE, 1000)
+ n100 = 1 + n100a / 100
+ n10_a = mod(n100a, 100)
+ n10 = 1 + n10_a / 10
+ n1 = 1 + mod(n10_a, 10)
+ m10 = 1 + mmarGE / 10
+ m1 = 1 + mod(mmarGE, 10)
+ jd10 = 1 + jdarGE / 10
+ jd1 = 1 + mod(jdarGE, 10)
+
+ ! +--1.2.1 Output File Label
+ ! + -----------------------
+
+ fnamNC_ice = 'ICE.' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1) &
+ //'.'//explIO &
+ //'.nc '
+
+ fnamNC_ics = 'ICS.' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1) &
+ //'.'//explIO &
+ //'.nc '
+
+ fnamNC_tmp = fnamNC_ice
+
+ if(snapshot .and. ss == 0) then
+ fnamNC_tmp = fnamNC_ics
+ endif
+
+ ! +--1.2.3 Output Title
+ ! + ------------------
+
+ tit_NC_ice = 'ICE' &
+ //' - Exp: '//explIO &
+ //' - ' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1)
+
+ ! +--1.2.4 Time Variable (hour)
+ ! + --------------------------
+
+ dt_ICE = 0
+ nbr_dt_ICE = nterun * dt * OutdyIB / 86400 ! Nbr of Outputs
+
+ nDFdim(0) = nbr_dt_ICE
+ nDFdim(0) = 0
+ NAMdim(0) = 'time'
+ UNIdim(0) = 'HOURS since 1901-01-15 00:00:00'
+
+ n1000 = 1 + iyr0GE / 1000
+ n100a = mod(iyr0GE, 1000)
+ n100 = 1 + n100a / 100
+ n10_a = mod(n100a, 100)
+ n10 = 1 + n10_a / 10
+ n1 = 1 + mod(n10_a, 10)
+ m10 = 1 + mma0GE / 10
+ m1 = 1 + mod(mma0GE, 10)
+ jd10 = 1 + jda0GE / 10
+ jd1 = 1 + mod(jda0GE, 10)
+
+ UNIdim(0) = 'MINUTES since ' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1)//'-' &
+ //labnum(m10)//labnum(m1)//'-' &
+ //labnum(jd10)//labnum(jd1)//' 00:00:00'
+
+ if(OutdyIB <= 24) &
+ UNIdim(0) = 'HOURS since ' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1)//'-' &
+ //labnum(m10)//labnum(m1)//'-' &
+ //labnum(jd10)//labnum(jd1)//' 00:00:00'
+
+ if(OutdyIB == 1) &
+ UNIdim(0) = 'DAYS since ' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1)//'-' &
+ //labnum(m10)//labnum(m1)//'-' &
+ //labnum(jd10)//labnum(jd1)//' 00:00:00'
+
+ if(nbr_dt_ICE > MXdim) &
+ STOP '*** OUTice - ERROR : MXdim to low ***'
+
+ ! date = (351 +(iyrrGE -1902) *365 ! Nb Days before iyrrGE
+ ! . +(iyrrGE -1901) / 4 ! Nb Leap Years
+ ! . + njyrGE(mmarGE) ! Nb Days before mmarGE
+ ! . + njybGE(mmarGE) ! (including Leap Day)
+ ! . * max(0,1-mod(iyrrGE,4)) !
+ ! . + jdarGE -1 )* 24 !
+ ! . + jhurGE !
+ ! . + (minuGE *60+jsecGE )/3600.!
+
+ date = nint(real(itexpe) * dt / 60.)
+ if(OutdyIB <= 24) date = nint(real(itexpe) * dt / (3600.))
+ if(OutdyIB == 1) date = nint(real(itexpe) * dt / (3600.*24.))
+ date0 = date
+
+ do it = 1, nbr_dt_ICE
+ ! Starting Time
+ timeNC_ice(it) = jhurGE + minuGE / 60.0 &
+ + jsecGE / 3600.0 &
+ + (it - 1) * 24.0 &
+ / real(max(OutdyIB, 1))
+ ! values of dim.time
+ VALdim(it, 0) = date + (it - 1) * 24.0 / real(max(OutdyIB, 1))
+ ! Time Variable
+ dateNC_ice(it) = timeNC_ice(it)
+ dayNC_ice(it) = jdarGE + timeNC_ice(it) / 24.0
+ enddo
+
+ month = mmarGE
+ mill = iyrrGE
+ do it = 1, nbr_dt_ICE
+ if(month == 2 .and. &
+ mod(mill, 4) == 0) then
+ njmo = njmoGE(month) + 1
+ else
+ njmo = njmoGE(month)
+ endif
+ if(dayNC_ice(it) > njmo) then
+ do iu = it, nbr_dt_ICE
+ dayNC_ice(iu) = dayNC_ice(iu) - njmo
+ enddo
+ month = month + 1
+ if(month > 12) then
+ month = 1
+ mill = mill + 1
+ endif
+ endif
+ monthNC_ice(it) = month
+ yearNC_ice(it) = mill
+
+ if(dateNC_ice(it) > 24.0 - epsi) then
+ do iu = it, nbr_dt_ICE
+ dateNC_ice(iu) = mod(dateNC_ice(iu), 24.0)
+ enddo
+ endif
+ enddo
+
+ do it = 1, nbr_dt_ICE
+ dateNC_ice(it) = dateNC_ice(it) &
+ + 1.d+2 * dayNC_ice(it) &
+ + 1.d+4 * monthNC_ice(it) &
+ + 1.d+6 * yearNC_ice(it)
+ enddo
+
+ ! +--1.2.5 Define horizontal spatial dimensions
+ ! + ------------------------------------------
+
+ do i = 1, mx
+ VALdim(i, 1) = xxkm(i)
+ !VALdim(i,1) = xxkm2(i) ! true distance
+ enddo
+ nDFdim(1) = mx
+ NAMdim(1) = 'x'
+ UNIdim(1) = 'km'
+
+ do j = 1, my
+ VALdim(j, 2) = yykm(j)
+ !VALdim(j,2) = yykm2(j) ! true distance
+ enddo
+ nDFdim(2) = my
+ NAMdim(2) = 'y'
+ UNIdim(2) = 'km'
+
+ do k = 1, nsx
+ VALdim(k, 3) = k
+ enddo
+ nDFdim(3) = nsx
+ NAMdim(3) = 'sector'
+ UNIdim(3) = 'level'
+
+ do k = 1, ml
+ VALdim(k, 4) = sigma(mz - k + 1)
+ dsigmaIB(k) = dsigm1(mz - k + 1)
+ enddo
+ nDFdim(4) = ml
+ NAMdim(4) = 'atmlay'
+ UNIdim(4) = 'sigma_level'
+
+ do k = 1, mlhh
+ VALdim(k, 5) = k * (24./real(mlhh))
+ enddo
+ nDFdim(5) = mlhh
+ NAMdim(5) = 'atmxh'
+ UNIdim(5) = 'hours'
+
+ do k = 1, mi
+ VALdim(k, 6) = OutshIB(k)
+ enddo
+ nDFdim(6) = mi
+ NAMdim(6) = 'outlay'
+ UNIdim(6) = 'm'
+
+ do k = 1, llx
+ VALdim(k, 7) = k
+ enddo
+ nDFdim(7) = llx
+ NAMdim(7) = 'sollay'
+ UNIdim(7) = 'layer'
+
+ do k = 1, nsno
+ VALdim(k, 8) = k
+ enddo
+ nDFdim(8) = nsno
+ NAMdim(8) = 'snolay'
+ UNIdim(8) = 'layer'
+
+ do k = 1, mp
+ VALdim(k, 9) = OutPLevIB(k)
+ enddo
+ nDFdim(9) = mp
+ NAMdim(9) = 'plev'
+ UNIdim(9) = 'hPa'
+
+ do k = 1, mztq
+ VALdim(k, 10) = OutZTQLevIB(k)
+ enddo
+ nDFdim(10) = mztq
+ NAMdim(10) = 'ztqlev'
+ UNIdim(10) = 'm'
+
+ do k = 1, mzuv
+ VALdim(k, 11) = OutZUVLevIB(k)
+ enddo
+ nDFdim(11) = mzuv
+ NAMdim(11) = 'zuvlev'
+ UNIdim(11) = 'm'
+
+ if(mlb > ml) then
+ print *, "ERROR mlb > ml"
+ stop
+ endif
+
+ do k = 1, mlb
+ VALdim(k, 12) = sigma(mz - k + 1)
+ enddo
+ nDFdim(12) = mlb
+ NAMdim(12) = 'blev'
+ UNIdim(12) = 'sigma_level'
+
+ ! +--1.2.6 Variable's Choice (Table ICEvou.dat)
+ ! + ------------------------------------------
+
+ OPEN(unit=10, status='unknown', file='ICEvou.dat')
+
+ itotNC_ice = 0
+980 continue
+ READ(10, '(A120)', end=990) tmpINP
+ if(tmpINP(1:4) == ' ') then
+ itotNC_ice = itotNC_ice + 1
+ ! Name
+ ! Names of Selected Dimensions
+ ! (max.4/variable)
+ !
+ !
+ ! Units
+ ! Description of the variable
+ READ(tmpINP, '(4x,5A9,A12,A50)') &
+ nameNC_ice(itotNC_ice), &
+ SdimNC_ice(1, itotNC_ice), &
+ SdimNC_ice(2, itotNC_ice), &
+ SdimNC_ice(3, itotNC_ice), &
+ SdimNC_ice(4, itotNC_ice), &
+ unitNC_ice(itotNC_ice), &
+ lnamNC_ice(itotNC_ice)
+
+ if(snapshot .and. ss == 0) then
+ if(nameNC_ice(itotNC_ice)(1:2) == "MB") itotNC_ice = itotNC_ice - 1
+ if(nameNC_ice(itotNC_ice)(3:1) == "h") itotNC_ice = itotNC_ice - 1
+ endif
+
+ endif
+ GOTO 980
+990 continue
+
+ CLOSE(unit=10)
+
+ NtotNC_ice = itotNC_ice ! Total number of variables
+ ! + ! writen in NetCDF file.
+
+ ! +--1.2.7 List of NetCDF attributes given to all variables
+ ! + ------------------------------------------------------
+
+ NAMrat(1) = 'actual_range' ! "actual_range" is (min,max)
+ NvatNC_ice(1) = 2 ! of all data for each variable
+
+ if(NattNC_ice == 2) then
+ NAMrat(NattNC_ice) = '[var]_range'
+ NvatNC_ice(NattNC_ice) = 2
+ endif
+
+ ! +--1.2.8 Automatic Generation of the NetCDF File Structure
+ ! + -------------------------------------------------------
+
+ ! + **************
+ call UNscreate(fnamNC_tmp, tit_NC_ice, &
+ NdimNC_ice, nDFdim, MXdim, &
+ NAMdim, UNIdim, VALdim, &
+ MX_var, NtotNC_ice, nameNC_ice, &
+ SdimNC_ice, unitNC_ice, lnamNC_ice, &
+ NattNC_ice, NAMrat, NvatNC_ice, &
+ ID__nc_ice)
+ ! + **************
+
+ print *, "Creation of "//trim(fnamNC_tmp)
+
+ ! +--1.2.9 Computation of inital mass balance variables (at itexpe=0)
+ ! + ----------------------------------------------------------------
+
+ tmp2_OK = 1.0
+ do j = jp11, my1
+ do i = ip11, mx1
+ do k = 1, nsx
+ tmp2_OK = min(tmp2_OK, &
+ max(zero, sign(unun, -mb0IB(i, j, k))))
+ enddo
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ do k = 1, nsx
+ if(nssSNo(i, j, k) >= 1) then
+ znsn1(nssSNo(i, j, k)) = dzsSNo(i, j, k, nssSNo(i, j, k))
+ snwae(nssSNo(i, j, k)) = rosSNo(i, j, k, nssSNo(i, j, k)) &
+ * dzsSNo(i, j, k, nssSNo(i, j, k)) &
+ * 1.e3 / ro_Wat &
+ * (1.+0.*wasSNo(i, j, k, nssSNo(i, j, k))) &
+ + SWaSNo(i, j, k)
+ do nk = nssSNo(i, j, k) - 1, 1, -1
+ znsn1(nk) = dzsSNo(i, j, k, nk) + znsn1(nk + 1)
+ snwae(nk) = rosSNo(i, j, k, nk) * dzsSNo(i, j, k, nk) &
+ * 1.e3 / ro_Wat &
+ * (1 + 0.*wasSNo(i, j, k, nk)) &
+ + snwae(nk + 1)
+ enddo
+ tmp1_OK = max(0, sign(1, nisSNo(i, j, k) - 1))
+ mb0IB(i, j, k) = tmp2_OK &
+ * (snwae(1) - snwae(nisSNo(i, j, k) + 1) * tmp1_OK) &
+ + (1.-tmp2_OK) * mb0IB(i, j, k)
+ zn0IB(i, j, k) = tmp2_OK &
+ * (znsn1(1) - znsn1(nisSNo(i, j, k) + 1) * tmp1_OK) &
+ + (1.-tmp2_OK) * zn0IB(i, j, k)
+ ! +... tmp1_OK = 1 if ice
+ ! + tmp2_OK = 0 if mb0IB is initialised
+ wet_IB(i, j, k) = snwae(1)
+ wet0IB(i, j, k) = snwae(1)
+ if(k == 1) smbh0IB(i, j) = snwae(1)
+ if(k == 1) swh0IB(i, j) = SWaSNo(i, j, k)
+ S_m_IB(i, j, k) = &
+ (snwae(1) - snwae(nisSNo(i, j, k) + 1) * tmp1_OK)
+ S_h_IB(i, j, k) = &
+ (znsn1(1) - znsn1(nisSNo(i, j, k) + 1) * tmp1_OK)
+ SIm_IB(i, j, k) = snwae(1)
+ SIh_IB(i, j, k) = znsn1(1)
+
+ do nk = 1, nsno
+ zn6IB(i, j, k) = dzsSNo(i, j, k, nk) + zn6IB(i, j, k)
+ enddo
+ zn6IB(i, j, k) = zn6IB(i, j, k) - zn0IB(i, j, k)
+
+ else
+ mb0IB(i, j, k) = 0.
+ zn0IB(i, j, k) = 0.
+ wet_IB(i, j, k) = 0.
+ wet0IB(i, j, k) = 0.
+ S_m_IB(i, j, k) = 0.
+ S_h_IB(i, j, k) = 0.
+ SIm_IB(i, j, k) = 0.
+ SIh_IB(i, j, k) = 0.
+ endif
+ xynsx1(i, j, k) = 1. ! 1. above 1st superimposed Ice Layer
+ SSh_IB(i, j, k) = 0. ! H (* without superimposed Ice)
+ enddo
+ enddo
+ enddo
+
+ ! cCA todo : useful?
+ ! #if(EU)
+ ! zn0IB = 0.
+ ! mb0IB = 0.
+ ! #endif
+
+ do kk = nsno, 1, -1
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ xynsx1(i, j, k) = xynsx1(i, j, k) &
+ * max(zero, sign(unun, 850.-rosSNo(i, j, k, kk)))
+ SSh_IB(i, j, k) = dzsSNo(i, j, k, kk) * xynsx1(i, j, k) &
+ + SSh_IB(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! +--1.2.10 Write Time - Constants
+ ! + -----------------------------
+
+ do j = 1, my
+ do i = 1, mx
+ Wkxy1(i, j) = GElonh(i, j) * 15.d0 ! Hour->degrees
+ WKxy2(i, j) = GElatr(i, j) / degrad ! rad ->degree
+ WKxy3(i, j) = real(mskSNo(i, j, 1)) ! REAL type
+ do k = 1, nsx
+ xynsx2(i, j, k) = real(mskSNo(i, j, k))
+ enddo
+ WKxy4(i, j) = real(isolTV(i, j)) ! REAL type
+ WKxy5(i, j) = real(isolSL(i, j)) ! REAL type
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'LON', 1, mx, my, 1, Wkxy1)
+ call UNwrite(ID__nc_ice, 'LAT', 1, mx, my, 1, Wkxy2)
+ call UNwrite(ID__nc_ice, 'SH', 1, mx, my, 1, sh)
+ CALL UNwrite(ID__nc_ice, 'AREA', 1, mx, my, 1, area)
+ CALL UNwrite(ID__nc_ice, 'DX', 1, mx, my, 1, dx3 / 1000.)
+ CALL UNwrite(ID__nc_ice, 'DY', 1, mx, my, 1, dy3 / 1000.)
+ call UNwrite(ID__nc_ice, 'SLO', 1, mx, my, 1, slopGE)
+ call UNwrite(ID__nc_ice, 'dsigma', 1, ml, 1, 1, dsigmaIB)
+
+ if(mw /= 5) then
+ call UNwrite(ID__nc_ice, 'MSK', 1, mx, my, 1, WKxy3)
+ else
+ call UNwrite(ID__nc_ice, 'MSK', 1, mx, my, nsx, xynsx2)
+ endif
+
+ call UNwrite(ID__nc_ice, 'SOL', 1, mx, my, 1, Wkxy4)
+ call UNwrite(ID__nc_ice, 'SRF', 1, mx, my, 1, Wkxy5)
+ ! + ************
+
+ do k = 1, min(nvx, nsx)
+ do j = 1, my
+ do i = 1, mx
+ Wkxy1(i, j) = real(czenGE(i, j))
+ WKxy2(i, j) = real(AlbSTV(i, j))
+ xynsx1(i, j, k) = real(ivegTV(i, j, k))
+ xynsx2(i, j, k) = real(ifraTV(i, j, k))
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nsx
+ slqmIB(i, j, k) = 0
+ slqcIB(i, j, k) = 0
+ do kk = -nsol, 0
+ slqmIB(i, j, k) = EtadSV(isolTV(i, j)) * 1000.*dzAvSV(kk) + slqmIB(i, j, k)
+ slqcIB(i, j, k) = Eta_TV(i, j, k, 1 - kk) * dzAvSV(kk) * ro_Wat + slqcIB(i, j, k)
+ enddo
+ wel0IB(i, j, k) = slqcIB(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'CZ', 1, mx, my, 1, Wkxy1)
+ call UNwrite(ID__nc_ice, 'SAL', 1, mx, my, 1, WKxy2)
+ call UNwrite(ID__nc_ice, 'VEG', 1, mx, my, nsx, xynsx1)
+ call UNwrite(ID__nc_ice, 'FRV', 1, mx, my, nsx, xynsx2)
+ call UNwrite(ID__nc_ice, 'SLQM', 1, mx, my, nsx, slqmIB)
+ call NCSNC(ID__nc_ice, RCODE)
+ ! + ************
+
+ ! date = (351+(iyrrGE -1902) *365 ! Nb Days before iyrrGE
+ ! . +(iyrrGE -1901) / 4 ! Nb Leap Years
+ ! . + njyrGE(mmarGE) ! Nb Days before mmarGE
+ ! . + njybGE(mmarGE) ! (including Leap Day)
+ ! . * max(0,1-mod(iyrrGE,4)) !
+ ! . + jdarGE -1 )* 24 !
+ ! . + jhurGE !
+ ! . + (0 *60 +0)/3600 !
+
+ date = nint(max(0., real(itexpe - 1)) * dt / 60.)
+ if(OutdyIB <= 24) date = nint(max(0., real(itexpe - 1)) * dt / (3600.))
+ if(OutdyIB == 1) date = nint(max(0., real(itexpe - 1)) * dt / (3600.*24.))
+ date0 = date
+
+ print *, "OUTice Initialization BEGIN", ss
+
+ write(6, 399) OutdyIB
+399 format(" OUTice: nbr of outputs by day:", i3)
+
+ write(6, 400) mz, mz - ml
+400 format(" OUTice: sigma levels kept:", i3, ' => ', i3)
+
+ write(6, 401) int(24./real(mlhh) * 60.)
+401 format(" OUTice: x-hourly outputs every:", i5, " minutes")
+
+ write(6, 402)(int(OutPLevIB(i)), i=mp, 1, -1)
+402 format(" OUTice: Pressure levels:", 20i4)
+
+ write(6, 403)(int(OutZTQLevIB(i)), i=1, mztq)
+403 format(" OUTice: Height levels:", 20i4)
+
+ write(6, 404)(OutshIB(i), i=1, mi)
+404 format(" OUTice: Snow height levels:", 30f5.1)
+
+ write(6, 405) nbr_call_outice
+405 format(" OUTice: called every ", i2, " time steps in mar.f")
+
+ print *, "OUTice Initialization END"
+
+ if(snapshot .and. ss == 1) then
+ ss = 0
+ goto 800
+ endif
+
+ ENDif ! Initialization
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++ 2. Every Time ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! +--2.1 Re-initialization
+ ! + =====================
+
+ ss = 0
+ if(snapshot) ss = 1
+
+ fnamNC_tmp = fnamNC_ice
+
+801 continue
+
+ if(dt_ICE2 == -1) then
+
+ dt_ICE2 = 0
+ timehIB = 0.
+ iyrrIB = 0
+
+ do j = 1, my
+ do i = 1, mx
+ swdIB(i, j) = 0. ! Shortwave incoming Radiation
+ swuIB(i, j) = 0. ! Shortwave outgoing Radiation
+ lwdIB(i, j) = 0. ! Longwave incoming Radiation
+ lwuIB(i, j) = 0. ! Longwave outgoing Radiation
+ swdtIB(i, j) = 0. ! TOA Shortwave incoming Radiation
+ swutIB(i, j) = 0. ! TOA Shortwave outgoing Radiation
+ lwutIB(i, j) = 0. ! TOA Longwave outgoing Radiation
+ sunIB(i, j) = 0. ! Sunshine
+ shfIB(i, j) = 0. ! Sensible Heat
+ lhfIB(i, j) = 0. ! Latent Heat
+ alIB(i, j) = 0. ! Albedo
+ as1_IB(i, j) = 0. ! Albedo
+ as2_IB(i, j) = 0. ! Albedo
+ as3_IB(i, j) = 0. ! Albedo
+ sicIB(i, j) = 0. ! Sea ice fraction
+ stIB(i, j) = 0. ! Surface Temperature
+ spIB(i, j) = 0. ! Surface Pressure
+ slpIB(i, j) = 0. ! Sea Surface Pressure
+ if(mw == 5) then
+ gradTIB(i, j) = 0. ! *CL* local temp. gradient
+ gradQIB(i, j) = 0. ! *CL* local hum. gradient
+ endif
+ ccIB(i, j) = 0. ! Cloud Cover
+ cuIB(i, j) = 0. ! Cloud Cover
+ cmIB(i, j) = 0. ! Cloud Cover
+ cdIB(i, j) = 0. ! Cloud Cover
+ codIB(i, j) = 0. ! Cloud Optical Depth
+ qwIB(i, j) = 0. ! Cloud Dropplets Concent
+ qiIB(i, j) = 0. ! Cloud Ice Crystals Concent.
+ qsIB(i, j) = 0. ! Cloud Snow Flakes Concent.
+ qrIB(i, j) = 0. ! Cloud Rain Concentration
+ wvpIB(i, j) = 0. ! Water Vapour Path / cCA old
+ cwpIB(i, j) = 0. ! Condensed Water Path / cCA old
+ iwpIB(i, j) = 0. ! Ice Water Path / cCA old
+ tcwvIB(i, j) = 0. ! Total column water vapor / cCA new
+ tclcIB(i, j) = 0. ! Total column liquid cloud / cCA new
+ tcicIB(i, j) = 0. ! Total column ice cloud / cCA new
+ tclpIB(i, j) = 0. ! Total column liquid precipitation / cCA new
+ tcipIB(i, j) = 0. ! Total column ice precipitation / cCA new
+ qbrIB(i, j) = 0. ! Snow ratio between kb level and surface
+ sicaoIB(i, j) = 0. ! SIC from OASIS
+ sitaoIB(i, j) = 0. ! sea ice thickness
+ sntaoIB(i, j) = 0. ! snow on sea ice thickness
+ if(mw == 5) then
+ mingrTIB(i, j) = 5. ! *CL* Maximum temp gradient the Day
+ maxgrTIB(i, j) = -5. ! *CL* Maximum temp gradient of the Day
+ mingrQIB(i, j) = 100. ! *CL* Maximum spec hum gradient the Day
+ maxgrQIB(i, j) = -100.! *CL* Maximum spec hum gradient of the Day
+ endif
+ pddIB(i, j) = 0. ! Positive degree day quantity
+ tnhIB0(i, j) = 99. ! Minimum Temp of the hour
+ txhIB0(i, j) = -99. ! Maximum Temp of the hour
+ enddo
+ enddo
+
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ al1IB(i, j, k) = 0. ! Albedo
+ al2IB(i, j, k) = 0. ! Albedo
+ frvIB(i, j, k) = 0. ! ifratv
+ st2IB(i, j, k) = 0. ! Surface Temperature
+ if(mw == 5) then
+ tt_intIB(i, j, k) = 0. ! *CL* Interpolated temperature
+ qq_intIB(i, j, k) = 0. ! *CL* Interpolated spec. hum.
+ endif
+ z0IB(i, j, k) = 0. ! Roughness length for Moment.
+ r0IB(i, j, k) = 0. ! Roughness length for Heat
+ uusIB(i, j, k) = 0. ! Friction Velocity
+ uusthIB(i, j, k) = 0. ! Threshold Friction Velocity
+ utsIB(i, j, k) = 0. ! Sfc Pot. Tp. Turb. Flux
+ uqsIB(i, j, k) = 0. ! Water Vapor Flux
+ ussIB(i, j, k) = 0. ! Blowing Snow Flux
+ pblIB(i, j, k) = 0. ! Height of Boundary Layer (2)
+ zn4IB(i, j, k) = 0. ! snowheight change due to compaction
+ zn5IB(i, j, k) = 0. ! snowheight change due to melting
+ ! output from coupling
+ st2aoIB(i, j, k) = 0. ! surface temperature from OASIS
+ albaoIB(i, j, k) = 0. ! albedo from OASIS
+ enddo
+ enddo
+ enddo
+
+ do kk = 1, ml
+ do j = 1, my
+ do i = 1, mx
+ mintIB(i, j, kk) = 60. ! Minimum Temp of the Day
+ maxtIB(i, j, kk) = -60. ! Maximum Temp of the Day
+ maxwIB(i, j, kk) = 0. ! Maximum Wind of the Day
+ ttIB(i, j, kk) = 0. ! Temperature
+ tdIB(i, j, kk) = 0. ! Temperature
+ uuIB(i, j, kk) = 0. ! x-Wind Speed component
+ vvIB(i, j, kk) = 0. ! y-Wind Speed component
+ if(track_wind) then
+ do itw = 1, ntrackwind
+ duIB(i, j, kk, itw) = 0. ! delta_u in m s-2
+ dvIB(i, j, kk, itw) = 0. ! delta_v in m s-2
+ enddo
+ endif
+ if(track_dgz) then
+ do itw = 1, ntrackdgz
+ dudgzIB(i, j, kk, itw) = 0. ! delta_u_dgz in m s-2
+ dvdgzIB(i, j, kk, itw) = 0. ! delta_v_dgz in m s-2
+ enddo
+ endif
+ wwIB(i, j, kk) = 0. ! w-Wind Speed component
+ psigIB(i, j, kk) = 0. ! psigDY : p* X Vertical Wind Speed (in sigma coordinate) (kPa/s)
+ wsigIB(i, j, kk) = 0. ! wsigDY : Vertical Wind Speed (in sigma coordinate) (1/s)
+ uvIB(i, j, kk) = 0. ! Horizontal Wind Speed
+ ruuIB(i, j, kk) = 0. ! x-Wind Speed component (reg grid)
+ rvvIB(i, j, kk) = 0. ! y-Wind Speed component (reg grid)
+ ruvIB(i, j, kk) = 0. ! Horizontal Wind Speed (reg grid)
+ qqIB(i, j, kk) = 0. ! Specific Humidity
+ if(track_water) then
+ do jtw = 1, ntwater
+ dqvIB(i, j, kk, jtw) = 0. ! delta_qv in (g/kg) / hour
+ enddo
+ endif
+ rhodzIB(i, j, kk) = 0. ! rho x dz = dsigma x SP / g
+ rolvIB(i, j, kk) = 0. ! Air Density
+ rhIB(i, j, kk) = 0. ! Relative Humidity
+ zzIB(i, j, kk) = 0. ! Model Levels Height
+ tkeIB(i, j, kk) = 0. ! TKE
+ lqsIB(i, j, kk) = 0. ! Snow flakes content at first levels
+ lqiIB(i, j, kk) = 0. ! Ice flakes content at first levels
+ lqrIB(i, j, kk) = 0. ! Rain flakes content at first levels
+ lqwIB(i, j, kk) = 0. ! Water flakes content at first levels
+ qsbIB(i, j, kk) = 0. ! Sublimation of Qs
+ lsbIB(i, j, kk) = 0. ! Total Vertical Integration of LH (k=1) + LH
+ swn3DIB(i, j, kk) = 0. ! SW net per atm. level
+ lwn3DIB(i, j, kk) = 0. ! LW net per atm. level
+ swnc3DIB(i, j, kk) = 0. ! Clear-sky SW net per atm. level
+ lwnc3DIB(i, j, kk) = 0. ! Clear-sky LW net per atm. level
+ cod3DIB(i, j, kk) = 0. ! Cloud Optical Depth per atm. level
+ cc3DIB(i, j, kk) = 0. ! Cloud Cover per atm. level
+ enddo
+ enddo
+ enddo
+
+ do kp = 1, mp
+ do j = 1, my
+ do i = 1, mx
+ nbpIB(i, j, kp) = 0 ! Count valid data on pressure levels
+ ttpIB(i, j, kp) = 0. ! Temperature
+ uupIB(i, j, kp) = 0. ! x-Wind Speed component
+ vvpIB(i, j, kp) = 0. ! y-Wind Speed component
+ wwpIB(i, j, kp) = 0. ! w-Wind Speed component
+ uvpIB(i, j, kp) = 0. ! Horizontal Wind Speed
+ qqpIB(i, j, kp) = 0. ! Specific Humidity
+ zzpIB(i, j, kp) = 0. ! Model Levels Height
+ enddo
+ enddo
+ enddo
+
+ do kz = 1, mztq
+ do j = 1, my
+ do i = 1, mx
+ ttzIB(i, j, kz) = 0. ! Temperature
+ rhzIB(i, j, kz) = 0. ! Temperature
+ qqzIB(i, j, kz) = 0. ! Specific Humidity
+ enddo
+ enddo
+ enddo
+
+ do kz = 1, mzuv
+ do j = 1, my
+ do i = 1, mx
+ uuzIB(i, j, kz) = 0. ! x-Wind Speed component
+ vvzIB(i, j, kz) = 0. ! y-Wind Speed component
+ u2zIB(i, j, kz) = 0. ! x-Wind Speed component
+ v2zIB(i, j, kz) = 0. ! y-Wind Speed component
+ uvzIB(i, j, kz) = 0. ! Horizontal Wind Speed
+ rozIB(i, j, kz) = 0. ! Air density
+ enddo
+ enddo
+ enddo
+
+ do kk = 1, llx
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ sltIB(i, j, k, kk) = 0 ! Soil Temperature
+ slqIB(i, j, k, kk) = 0 ! Soil Humidity Content
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do kk = 1, mi
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ agIB(i, j, k, kk) = 0. ! Average ag
+ g1IB(i, j, k, kk) = 0. ! Average g1
+ g2IB(i, j, k, kk) = 0. ! Average g2
+ roIB(i, j, k, kk) = 0. ! Average ro
+ tiIB(i, j, k, kk) = 0. ! Average ti
+ waIB(i, j, k, kk) = 0. ! Avegage wa
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! +--2.2 Putting Values in Matrices
+ ! + ==============================
+
+ dt_ICE2 = dt_ICE2 + 1
+
+ ! +--2.2.1 Atmospheric variables
+ ! + ---------------------------
+
+ if(nsx < 2) then
+ print *, "mw <2!!!!"
+ stop
+ endif
+
+ !$OMP PARALLEL do default(shared) &
+ !$OMP private(i,j,k,kz,zDown,zLev,distUp,kUp,kDown,kMiddle, &
+ !$OMP zMiddle,zUp,pDown,pLev,pMiddle,kk,q,qst,r,rst,rh1,rh2, &
+ !$OMP rh,tmp1z,tmp2z,tmp3,tmp4,nk,depthsnow,tmp,phi,cphi,sphi)
+ do j = 1, my
+ do i = 1, mx
+ qbrIB(i, j) = qbrIB(i, j) + qbs_HY(i, j)
+ if(mw == 5) then
+ maxgrTIB(i, j) = max(gradTM(i, j), maxgrTIB(i, j)) ! *CL*
+ mingrTIB(i, j) = min(gradTM(i, j), mingrTIB(i, j)) ! *CL*
+ maxgrQIB(i, j) = max(gradQM(i, j), maxgrQIB(i, j)) ! *CL*
+ mingrQIB(i, j) = min(gradQM(i, j), mingrQIB(i, j)) ! *CL*
+ endif
+
+ do k = 1, mz
+ phi = (-1.) * (gelonh(i, j) * 15.+90.-GEddxx) * degrad
+ cphi = cos(-phi)
+ sphi = sin(-phi)
+ rotuuIB(i, j, k) = cphi * uairDY(i, j, k) - sphi * vairDY(i, j, k)
+ rotvvIB(i, j, k) = sphi * uairDY(i, j, k) + cphi * vairDY(i, j, k)
+ enddo
+
+ do kk = 1, ml
+
+ q = qvDY(i, j, mz - kk + 1)
+ qst = qsat0D(tairDY(i, j, mz - kk + 1), &
+ sigma(mz - kk + 1), pstDY(i, j), ptopDY, 1)
+
+ r = q / max(epsi, 1.-q)
+ rst = qst / max(epsi, 1.-qst)
+
+ rh = (r / (0.622 + r)) &
+ / max(epsi,(rst / (0.622 + rst))) * 100.
+ rh = max(0., min(100., rh))
+ tdIB(i, j, kk) = tdIB(i, j, kk) + &
+ 243.5 * &
+ (log(rh / 100.) &
+ + ((17.67 * (tairDY(i, j, mz - kk + 1) - TfSnow)) &
+ / (243.5 + (tairDY(i, j, mz - kk + 1) - TfSnow)))) / &
+ (17.67 - Log(rh / 100.) &
+ - ((17.67 * (tairDY(i, j, mz - kk + 1) - TfSnow)) &
+ / (243.5 + (tairDY(i, j, mz - kk + 1) - TfSnow))))
+
+ mintIB(i, j, kk) = min(tairDY(i, j, mz - kk + 1) - TfSnow, &
+ mintIB(i, j, kk))
+ maxtIB(i, j, kk) = max(tairDY(i, j, mz - kk + 1) - TfSnow, &
+ maxtIB(i, j, kk))
+
+ maxwIB(i, j, kk) = max( &
+ (uairDY(i, j, mz - kk + 1)**2 + vairDY(i, j, mz - kk + 1)**2)**0.5, &
+ maxwIB(i, j, kk))
+ ttIB(i, j, kk) = ttIB(i, j, kk) + tairDY(i, j, mz - kk + 1) - TfSnow
+ uuIB(i, j, kk) = uuIB(i, j, kk) + uairDY(i, j, mz - kk + 1)
+ vvIB(i, j, kk) = vvIB(i, j, kk) + vairDY(i, j, mz - kk + 1)
+ if(track_wind) then
+ do itw = 1, ntrackwind
+ ! duIB and dvIB in (m s-1) / h : delta wind by hour
+ duIB(i, j, kk, itw) = duIB(i, j, kk, itw) + &
+ (delta_u(i, j, mz - kk + 1, itw) - &
+ delta_u_IBsave(i, j, mz - kk + 1, itw)) / dt * 3600.
+ dvIB(i, j, kk, itw) = dvIB(i, j, kk, itw) + &
+ (delta_v(i, j, mz - kk + 1, itw) - &
+ delta_v_IBsave(i, j, mz - kk + 1, itw)) / dt * 3600.
+ delta_u_IBsave(i, j, mz - kk + 1, itw) = delta_u(i, j, mz - kk + 1, itw)
+ delta_v_IBsave(i, j, mz - kk + 1, itw) = delta_v(i, j, mz - kk + 1, itw)
+ enddo
+ endif
+ if(track_dgz) then
+ do itw = 1, ntrackdgz
+ ! dudgzIB and dvdgzIB in (m s-1) / h : delta wind by hour
+ dudgzIB(i, j, kk, itw) = dudgzIB(i, j, kk, itw) + &
+ (delta_u_dgz(i, j, mz - kk + 1, itw) &
+ - delta_u_dgz_IBsave(i, j, mz - kk + 1, itw)) / &
+ dt * 3600.
+ dvdgzIB(i, j, kk, itw) = dvdgzIB(i, j, kk, itw) + &
+ (delta_v_dgz(i, j, mz - kk + 1, itw) - &
+ delta_v_dgz_IBsave(i, j, mz - kk + 1, itw)) / &
+ dt * 3600.
+ delta_u_dgz_IBsave(i, j, mz - kk + 1, itw) = delta_u_dgz(i, j, mz - kk + 1, itw)
+ delta_v_dgz_IBsave(i, j, mz - kk + 1, itw) = delta_v_dgz(i, j, mz - kk + 1, itw)
+ enddo
+ endif
+ uvIB(i, j, kk) = uvIB(i, j, kk) + &
+ (uairDY(i, j, mz - kk + 1)**2 + vairDY(i, j, mz - kk + 1)**2)**0.5
+ wwIB(i, j, kk) = wwIB(i, j, kk) + wairDY(i, j, mz - kk + 1)
+ psigIB(i, j, kk) = psigIB(i, j, kk) + psigDY(i, j, mz - kk + 1)
+ wsigIB(i, j, kk) = wsigIB(i, j, kk) + wsigDY(i, j, mz - kk + 1)
+
+ ruuIB(i, j, kk) = ruuIB(i, j, kk) + rotuuIB(i, j, mz - kk + 1)
+ rvvIB(i, j, kk) = rvvIB(i, j, kk) + rotvvIB(i, j, mz - kk + 1)
+ ruvIB(i, j, kk) = ruvIB(i, j, kk) + &
+ (rotuuIB(i, j, mz - kk + 1)**2 + rotvvIB(i, j, mz - kk + 1)**2)**0.5
+
+ qqIB(i, j, kk) = qqIB(i, j, kk) + qvDY(i, j, mz - kk + 1) * 1000.
+
+ if(track_water) then
+ do jtw = 1, ntwater
+ ! dqvIB in (g/kg) / h : delta qv by hour
+ dqvIB(i, j, kk, jtw) = dqvIB(i, j, kk, jtw) + &
+ (delta_qv(i, j, mz - kk + 1, jtw) - delta_qv_IBsave(i, j, mz - kk + 1, jtw)) / &
+ dt * 3600.*1000.
+ delta_qv_IBsave(i, j, mz - kk + 1, jtw) = delta_qv(i, j, mz - kk + 1, jtw)
+ enddo
+ endif
+
+ ! rhodz : rho dz = dp / g = dsigma * SP / g (kg m-2)
+ ! rhodz : *1000 : kPa -> Pa
+ rhodzIB(i, j, kk) = rhodzIB(i, j, kk) + dsigmaIB(kk) * (pstDY(i, j) + ptopDY) * 1000.*grvinv
+ rolvIB(i, j, kk) = rolvIB(i, j, kk) + rolvDY(i, j, mz - kk + 1) * 1000.
+ rhIB(i, j, kk) = rhIB(i, j, kk) + rh
+ zzIB(i, j, kk) = zzIB(i, j, kk) + gplvDY(i, j, mz - kk + 1) * grvinv
+ tkeIB(i, j, kk) = tkeIB(i, j, kk) + ect_TE(i, j, mz - kk + 1)
+ lqsIB(i, j, kk) = lqsIB(i, j, kk) + qsHY(i, j, mz - kk + 1) * 1000.
+ lqiIB(i, j, kk) = lqiIB(i, j, kk) + qiHY(i, j, mz - kk + 1) * 1000.
+ lqrIB(i, j, kk) = lqrIB(i, j, kk) + qrHY(i, j, mz - kk + 1) * 1000.
+ lqwIB(i, j, kk) = lqwIB(i, j, kk) + qwHY(i, j, mz - kk + 1) * 1000.
+ qsbIB(i, j, kk) = qsbIB(i, j, kk) + hsubHY(i, j, mz - kk + 1) * 1000.
+ lsbIB(i, j, kk) = lsbIB(i, j, kk) + hlatHY(i, j, mz - kk + 1)
+ swn3DIB(i, j, kk) = swn3DIB(i, j, kk) + RAfnSO(i, j, mz - kk + 1)
+ lwn3DIB(i, j, kk) = lwn3DIB(i, j, kk) + RAfnIR(i, j, mz - kk + 1)
+ swnc3DIB(i, j, kk) = swnc3DIB(i, j, kk) + RAfncSO(i, j, mz - kk + 1)
+ lwnc3DIB(i, j, kk) = lwnc3DIB(i, j, kk) + RAfncIR(i, j, mz - kk + 1)
+
+ ! !Cloud variables
+ cc3DIB(i, j, kk) = cc3DIB(i, j, kk) + CldFRA(i, j, mz - kk + 1)
+ do k = 1, 3
+ tmp(k) = 0.0
+ enddo
+ tmp(3) = (pstDY(i, j) * sigma(mz - kk + 1) + ptopDY) &
+ / (ra * tairDY(i, j, mz - kk + 1) &
+ * (1.+.608 * qvDY(i, j, mz - kk + 1))) &
+ * (gpmiDY(i, j, mz - kk + 1) - gpmiDY(i, j, mz - kk + 1 + 1))
+ tmp(1) = tmp(3) * qwHY(i, j, mz - kk + 1)
+ tmp(2) = tmp(3) * qiHY(i, j, mz - kk + 1)
+ cod3DIB(i, j, kk) = 1.5 * (tmp(1) / 20.d-6 &
+ + tmp(2) / 40.d-6) * grvinv &
+ + cod3DIB(i, j, kk)
+ enddo
+
+ do kk = 1, mz
+ tmp1z(kk) = ect_TE(i, j, kk)
+ tmp2z(kk) = gplvDY(i, j, kk) * grvinv - sh(i, j)
+ enddo
+
+ ! + ************
+ call PBLtop(tmp1z, tmp2z, tmp3, tmp4)
+ ! + ************
+
+ pblIB(i, j, 1) = pblIB(i, j, 1) + tmp3
+ pblIB(i, j, 2) = pblIB(i, j, 2) + tmp4
+
+ spIB(i, j) = spIB(i, j) + pstDY(i, j) * 10. ! kPa -> hPa
+
+ if(mw == 5) then
+ gradTIB(i, j) = gradTIB(i, j) + gradTM(i, j) !*CL*
+ gradQIB(i, j) = gradQIB(i, j) + gradQM(i, j) !*CL*
+ do k = 1, nsx
+ tt_intIB(i, j, k) = tt_intIB(i, j, k) - TfSnow + tairDY_int(i, j, k) !*CL*
+ qq_intIB(i, j, k) = qq_intIB(i, j, k) + qvDY_int(i, j, k) * 1000. !*CL*
+ enddo
+ endif
+
+ enddo
+ ! end do
+
+ ! +--2.2.3 Atmospheric variables on pressure levels
+ ! + ----------------------------------------------
+
+ ! do j=1,my
+ do i = 1, mx
+ pDown = (pstDY(i, j) * sigma(mz) + ptopDY) * 10
+ do kp = 1, mp
+ pLev = OutPLevIB(kp)
+ if(pLev <= pDown) then
+ nbpIB(i, j, kp) = nbpIB(i, j, kp) + 1
+ kUp = 1
+ kDown = mz
+ do WHILE(kDown - kUp > 1)
+ kMiddle = (kDown + kUp) / 2
+ pMiddle = (pstDY(i, j) * sigma(kMiddle) + &
+ ptopDY) * 10
+ if(pMiddle >= pLev) then
+ kDown = kMiddle
+ else
+ kUp = kMiddle
+ endif
+ enddo
+ pUp = (pstDY(i, j) * sigma(kUp) + ptopDY) * 10
+ pDown = (pstDY(i, j) * sigma(kDown) + ptopDY) * 10
+ distUp = (pLev - pUp) / (pDown - pUp)
+ tairDYp(i, j, kp) = distUp * tairDY(i, j, kDown) + &
+ (1 - distUp) * tairDY(i, j, kUp)
+ qvDYp(i, j, kp) = distUp * qvDY(i, j, kDown) + &
+ (1 - distUp) * qvDY(i, j, kUp)
+ gplvDYp(i, j, kp) = distUp * gplvDY(i, j, kDown) + &
+ (1 - distUp) * gplvDY(i, j, kUp)
+ uairDYp(i, j, kp) = distUp * uairDY(i, j, kDown) + &
+ (1 - distUp) * uairDY(i, j, kUp)
+ vairDYp(i, j, kp) = distUp * vairDY(i, j, kDown) + &
+ (1 - distUp) * vairDY(i, j, kUp)
+ wairDYp(i, j, kp) = distUp * wairDY(i, j, kDown) + &
+ (1 - distUp) * wairDY(i, j, kUp)
+ ! ! sum for the output
+ ttpIB(i, j, kp) = ttpIB(i, j, kp) + &
+ tairDYp(i, j, kp) - TfSnow
+ qqpIB(i, j, kp) = qqpIB(i, j, kp) + &
+ qvDYp(i, j, kp) * 1000.
+ zzpIB(i, j, kp) = zzpIB(i, j, kp) + &
+ gplvDYp(i, j, kp) * grvinv
+ uupIB(i, j, kp) = uupIB(i, j, kp) + uairDYp(i, j, kp)
+ vvpIB(i, j, kp) = vvpIB(i, j, kp) + vairDYp(i, j, kp)
+ wwpIB(i, j, kp) = wwpIB(i, j, kp) + wairDYp(i, j, kp)
+ uvpIB(i, j, kp) = uvpIB(i, j, kp) + &
+ (uairDYp(i, j, kp)**2 + vairDY(i, j, kp)**2)**0.5
+ endif
+ enddo
+ enddo
+ ! end do
+
+ ! +--2.2.4 Atmospheric variables on heigth levels (z)
+ ! + ------------------------------------------------
+
+ ! +--2.2.4.1 Temperature
+
+ ! do j=1,my
+ do i = 1, mx
+ zDown = gplvDY(i, j, mz) * grvinv - sh(i, j)
+ do kz = 1, mztq
+ zLev = OutZTQLevIB(kz)
+ if(zLev < zDown) then
+ distUp = (zDown - zLev) / zDown
+ ttzIB_0(i, j, kz) = distUp * tairSL(i, j) + &
+ (1 - distUp) * tairDY(i, j, mz)
+ qqzIB_0(i, j, kz) = distUp * qvapSL(i, j) + &
+ (1 - distUp) * qvDY(i, j, mz)
+ ppzIB_0(i, j, kz) = (pstDY(i, j) &
+ * sigma(kUp) + ptopDY) * 10
+
+ q = qvapSL(i, j)
+ qst = qsat0D(tairSL(i, j), &
+ 1., pstDY(i, j), ptopDY, 1)
+ r = q / max(epsi, 1.-q)
+ rst = qst / max(epsi, 1.-qst)
+ rh = (r / (0.622 + r)) &
+ / max(epsi,(rst / (0.622 + rst))) * 100.
+ rh1 = max(0., min(100., rh))
+
+ q = qvDY(i, j, mz)
+ qst = qsat0D(tairDY(i, j, mz), &
+ sigma(mz), pstDY(i, j), ptopDY, 1)
+ r = q / max(epsi, 1.-q)
+ rst = qst / max(epsi, 1.-qst)
+ rh = (r / (0.622 + r)) &
+ / max(epsi,(rst / (0.622 + rst))) * 100.
+ rh2 = max(0., min(100., rh))
+
+ rhzIB_0(i, j, kz) = distUp * rh1 + &
+ (1 - distUp) * rh2
+
+ else
+ kUp = 1
+ kDown = mz
+ do WHILE(kDown - kUp > 1)
+ kMiddle = (kDown + kUp) / 2
+ zMiddle = gplvDY(i, j, kMiddle) * grvinv - sh(i, j)
+ if(zMiddle <= zLev) then
+ kDown = kMiddle
+ else
+ kUp = kMiddle
+ endif
+ enddo
+ zUp = gplvDY(i, j, kUp) * grvinv - sh(i, j)
+ zDown = gplvDY(i, j, kDown) * grvinv - sh(i, j)
+ distUp = (zUp - zLev) / (zUp - zDown)
+ ttzIB_0(i, j, kz) = distUp * tairDY(i, j, kDown) + &
+ (1 - distUp) * tairDY(i, j, kUp)
+ qqzIB_0(i, j, kz) = distUp * qvDY(i, j, kDown) + &
+ (1 - distUp) * qvDY(i, j, kUp)
+ ppzIB_0(i, j, kz) = distUp * &
+ (pstDY(i, j) * sigma(kDown) + ptopDY) * 10 &
+ + (1 - distUp) * &
+ (pstDY(i, j) * sigma(kUp) + ptopDY) * 10
+
+
+ q = qvDY(i, j, kDown)
+ qst = qsat0D(tairDY(i, j, kDown), &
+ sigma(kDown), pstDY(i, j), ptopDY, 1)
+ r = q / max(epsi, 1.-q)
+ rst = qst / max(epsi, 1.-qst)
+ rh = (r / (0.622 + r)) &
+ / max(epsi,(rst / (0.622 + rst))) * 100.
+ rh1 = max(0., min(100., rh))
+
+ q = qvDY(i, j, kUp)
+ qst = qsat0D(tairDY(i, j, kUp), &
+ sigma(kUp), pstDY(i, j), ptopDY, 1)
+ r = q / max(epsi, 1.-q)
+ rst = qst / max(epsi, 1.-qst)
+ rh = (r / (0.622 + r)) &
+ / max(epsi,(rst / (0.622 + rst))) * 100.
+ rh2 = max(0., min(100., rh))
+
+ rhzIB_0(i, j, kz) = distUp * rh1 + &
+ (1 - distUp) * rh2
+
+
+ endif
+ ! ! sum for the output
+ ttzIB(i, j, kz) = ttzIB(i, j, kz) + &
+ ttzIB_0(i, j, kz) - TfSnow
+ qqzIB(i, j, kz) = qqzIB(i, j, kz) + &
+ qqzIB_0(i, j, kz) * 1000.
+ rhzIB(i, j, kz) = rhzIB(i, j, kz) + &
+ rhzIB_0(i, j, kz)
+ enddo
+ enddo
+ ! end do
+
+ ! +--2.2.4.2 Wind
+ ! do j=1,my
+ do i = 1, mx
+ zDown = gplvDY(i, j, mz) * grvinv - sh(i, j)
+ do kz = 1, mzuv
+ zLev = OutZUVLevIB(kz)
+ if(zLev < zDown) then
+ distUp = (zDown - zLev) / zDown
+ uuzIB_0(i, j, kz) = distUp * 0.+ &
+ (1 - distUp) * uairDY(i, j, mz)
+ vvzIB_0(i, j, kz) = distUp * 0.+ &
+ (1 - distUp) * vairDY(i, j, mz)
+ u2zIB_0(i, j, kz) = distUp * 0.+(1 - distUp) * rotuuIB(i, j, mz)
+ v2zIB_0(i, j, kz) = distUp * 0.+(1 - distUp) * rotvvIB(i, j, mz)
+ rozIB_0(i, j, kz) = distUp * 0.+ &
+ (1 - distUp) * rolvDY(i, j, mz)
+ else
+ kUp = 1
+ kDown = mz
+ do WHILE(kDown - kUp > 1)
+ kMiddle = (kDown + kUp) / 2
+ zMiddle = gplvDY(i, j, kMiddle) * grvinv - sh(i, j)
+ if(zMiddle <= zLev) then
+ kDown = kMiddle
+ else
+ kUp = kMiddle
+ endif
+ enddo
+ zUp = gplvDY(i, j, kUp) * grvinv - sh(i, j)
+ zDown = gplvDY(i, j, kDown) * grvinv - sh(i, j)
+ distUp = (zUp - zLev) / (zUp - zDown)
+ uuzIB_0(i, j, kz) = distUp * uairDY(i, j, kDown) + &
+ (1 - distUp) * uairDY(i, j, kUp)
+ vvzIB_0(i, j, kz) = distUp * vairDY(i, j, kDown) + &
+ (1 - distUp) * vairDY(i, j, kUp)
+ u2zIB_0(i, j, kz) = distUp * rotuuIB(i, j, kDown) + &
+ (1 - distUp) * rotuuIB(i, j, kUp)
+ v2zIB_0(i, j, kz) = distUp * rotvvIB(i, j, kDown) + &
+ (1 - distUp) * rotvvIB(i, j, kUp)
+ rozIB_0(i, j, kz) = distUp * rolvDY(i, j, kDown) + &
+ (1 - distUp) * rolvDY(i, j, kUp)
+ endif
+ ! ! sum for the output
+ uuzIB(i, j, kz) = uuzIB(i, j, kz) + uuzIB_0(i, j, kz)
+ vvzIB(i, j, kz) = vvzIB(i, j, kz) + vvzIB_0(i, j, kz)
+ u2zIB(i, j, kz) = u2zIB(i, j, kz) + u2zIB_0(i, j, kz)
+ v2zIB(i, j, kz) = v2zIB(i, j, kz) + v2zIB_0(i, j, kz)
+ uvzIB(i, j, kz) = uvzIB(i, j, kz) + &
+ (uuzIB_0(i, j, kz)**2.+vvzIB_0(i, j, kz)**2.)**0.5
+ rozIB(i, j, kz) = rozIB(i, j, kz) + rozIB_0(i, j, kz) * 1000.
+ enddo
+ enddo
+ ! end do
+
+ ! +--2.2.4.3 sea level pressure
+ ! do j=1,my
+ do i = 1, mx
+
+ ! ! vertical gradiant between mz-15 and mz-10
+ ! zUp = gplvDY(i,j,mz-15) * grvinv
+ ! zDown = gplvDY(i,j,mz-10) * grvinv
+
+ ! tmp3=
+ ! . (tairDY(i,j,mz-10)-tairDY(i,j,mz-15))/
+ ! . (zup - zDown)
+ ! tmp3=max(0.005,min(0.01,tmp3))
+ tmp3 = 0.0065 ! standard gradiant
+
+ slpIB(i, j) = slpIB(i, j) + &
+ (pstDY(i, j) * sigma(mz - 3) + ptopDY) * 10 * &
+ (1 - tmp3 * gplvDY(i, j, mz - 3) * grvinv / &
+ (tairDY(i, j, mz - 3) + tmp3 * gplvDY(i, j, mz - 3) * grvinv)) &
+ **(-5.257)
+
+ enddo
+
+ ! end do
+
+ ! +--2.2.4.3 X-hourly variables
+ ! + --------------------------
+
+ ! do j=1,my
+ do i = 1, mx
+ tnhIB0(i, j) = min(tairDY(i, j, mz) - TfSnow, tnhIB0(i, j))
+ txhIB0(i, j) = max(tairDY(i, j, mz) - TfSnow, txhIB0(i, j))
+ enddo
+ ! end do
+
+ ! +--2.2.4 Surface variables
+ ! + -----------------------
+
+ ! do j=jp11,my1
+ do i = ip11, mx1
+
+ if(RAdsol(i, j) > 120) sunIB(i, j) = sunIB(i, j) + dt * nbr_call_outice
+ ! outice is called every x time steps
+
+ swdIB(i, j) = RAdsol(i, j) + swdIB(i, j)
+ swuIB(i, j) = albeSL(i, j) * RAdsol(i, j) + swuIB(i, j)
+ lwdIB(i, j) = RAd_ir(i, j) + lwdIB(i, j)
+ lwuIB(i, j) = firmSL(i, j) + lwuIB(i, j)
+
+ lwutIB(i, j) = RAdOLR(i, j) + lwutIB(i, j)
+ swutIB(i, j) = RAdOSR(i, j) + swutIB(i, j)
+ swdtIB(i, j) = rsunGE * czenGE(i, j) + swdtIB(i, j)
+ shfIB(i, j) = -hsenSL(i, j) + shfIB(i, j)
+ lhfIB(i, j) = -hlatSL(i, j) + lhfIB(i, j)
+ alIB(i, j) = albeSL(i, j) + alIB(i, j)
+ as1_IB(i, j) = alb1IB(i, j) + as1_IB(i, j)
+ as2_IB(i, j) = alb2IB(i, j) + as2_IB(i, j)
+ as3_IB(i, j) = alb3IB(i, j) + as3_IB(i, j)
+ stIB(i, j) = tairsl(i, j) - TfSnow + stIB(i, j)
+ sicIB(i, j) = ifratv(i, j, 2) + sicIB(i, j)
+ pddIB(i, j) = pddIB(i, j) + &
+ (tairDY(i, j, mz) - TfSnow) &
+ * max(zero, sign(unun, &
+ tairDY(i, j, mz) - TfSnow))
+ if(coupling_ao .eqv. .true.) then
+ sicaoIB(i, j) = sicsAO(i, j) + sicaoIB(i, j)
+ sitaoIB(i, j) = hicao(i, j) + sitaoIB(i, j)
+ sntaoIB(i, j) = hsnoao(i, j) + sntaoIB(i, j)
+ endif
+
+ do k = 1, nsx
+ al1IB(i, j, k) = RAdsol(i, j) * albxSL(i, j, k) + al1IB(i, j, k)
+ al2IB(i, j, k) = albxSL(i, j, k) + al2IB(i, j, k)
+ frvIB(i, j, k) = ifratv(i, j, k) + frvIB(i, j, k)
+ st2IB(i, j, k) = tsrfSL(i, j, k) - TfSnow + st2IB(i, j, k)
+ z0IB(i, j, k) = SL_Z0(i, j, k) + z0IB(i, j, k)
+ r0IB(i, j, k) = SL_R0(i, j, k) + r0IB(i, j, k)
+ uusIB(i, j, k) = SLuusl(i, j, k) + uusIB(i, j, k)
+ utsIB(i, j, k) = SLutsl(i, j, k) + utsIB(i, j, k)
+ uqsIB(i, j, k) = SLuqsl(i, j, k) + uqsIB(i, j, k)
+ ussIB(i, j, k) = SLussl(i, j, k) + ussIB(i, j, k)
+ uusthIB(i, j, k) = SaltSN(i, j, k) + uusthIB(i, j, k)
+ if(coupling_ao .eqv. .true.) then
+ st2aoIB(i, j, k) = srftao(i, j, k) + st2aoIB(i, j, k)
+ albaoIB(i, j, k) = albao(i, j, k) + albaoIB(i, j, k)
+ endif
+ enddo
+ enddo
+ ! end do
+
+ ! +--2.2.5 Cloud Variables
+ ! + ---------------------
+ ! do j=1,my
+ do i = 1, mx
+ do k = 1, 3
+ tmp(k) = 0.0
+ enddo
+ do k = mzhyd, mz
+ tmp(3) = (pstDY(i, j) * sigma(k) + ptopDY) &
+ / (ra * tairDY(i, j, k) * (1.+.608 * qvDY(i, j, k))) &
+ * (gpmiDY(i, j, k) - gpmiDY(i, j, k + 1))
+ tmp(1) = tmp(1) + tmp(3) * qwHY(i, j, k)
+ tmp(2) = tmp(2) + tmp(3) * qiHY(i, j, k)
+ enddo
+ codIB(i, j) = 1.5 * (tmp(1) / 20.d-6 &
+ + tmp(2) / 40.d-6) * grvinv &
+ + codIB(i, j)
+ !C#EE codIB(i,j) = RAcdtO(i,j)+codIB (i,j)
+
+ do k = mzhyd, mz
+ ! todo : old computation [cCA 02/08/2022], remove ?
+ ! =================================================
+ tmp(1) = rolvDY(i, j, k) * 1000. &
+ *((gplvDY(i, j, k - 1) + gplvDY(i, j, k)) / 2. &
+ -(gplvDY(i, j, k) + gplvDY(i, j, k + 1)) / 2.) &
+ * grvinv
+ wvpIB(i, j) = wvpIB(i, j) + qvDY(i, j, k) * tmp(1)
+ cwpIB(i, j) = cwpIB(i, j) + (qwHY(i, j, k) + qrHY(i, j, k)) * tmp(1)
+ iwpIB(i, j) = iwpIB(i, j) + (qiHY(i, j, k) + qsHY(i, j, k)) * tmp(1)
+ qwIB(i, j) = qwIB(i, j) + qwHY(i, j, k) * tmp(1)
+ qiIB(i, j) = qiIB(i, j) + qiHY(i, j, k) * tmp(1)
+ qsIB(i, j) = qsIB(i, j) + qsHY(i, j, k) * tmp(1)
+ qrIB(i, j) = qrIB(i, j) + qrHY(i, j, k) * tmp(1)
+ ! water content: standard computation [cCA 02/08/2022]
+ ! =================================================
+ ! rhodz : rho dz = dp / g = dsigma * SP / g (kg m-2)
+ ! rhodz : for staggered grid (usual MAR setting), dsigma = dsigm1
+ rhodz = dsigm1(k) * (pstDY(i, j) + ptopDY) * 1000.*grvinv ! *1000 : kPa -> Pa
+ tcwvIB(i, j) = tcwvIB(i, j) + qvDY(i, j, k) * rhodz
+ tclcIB(i, j) = tclcIB(i, j) + qwHY(i, j, k) * rhodz
+ tcicIB(i, j) = tcicIB(i, j) + qiHY(i, j, k) * rhodz
+ tclpIB(i, j) = tclpIB(i, j) + qrHY(i, j, k) * rhodz
+ tcipIB(i, j) = tcipIB(i, j) + qsHY(i, j, k) * rhodz
+ enddo
+ ccIB(i, j) = cld_SL(i, j) + ccIB(i, j)
+ cuIB(i, j) = clduSL(i, j) + cuIB(i, j)
+ cmIB(i, j) = cldmSL(i, j) + cmIB(i, j)
+ cdIB(i, j) = clddSL(i, j) + cdIB(i, j)
+ enddo
+ ! end do
+
+ ! +--2.2.6 Soil Variables
+ ! + --------------------
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ do k = 1, nsx
+ do kk = 1, llx
+ sltIB(i, j, k, kk) = TsolTV(i, j, k, kk) - TfSnow + sltIB(i, j, k, kk)
+ slqIB(i, j, k, kk) = Eta_TV(i, j, k, kk) * 1000.+slqIB(i, j, k, kk)
+ enddo
+ enddo
+ enddo
+ ! end do
+
+ ! +--2.2.7 Snow Pack Variables
+ ! + -------------------------
+ do k = 1, nsx
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ if(nssSNo(i, j, k) > 1) then
+ depthsnow(nssSNo(i, j, k)) = dzsSNo(i, j, k, nssSNo(i, j, k)) / 2.
+ do nk = nssSNo(i, j, k) - 1, 1, -1
+ depthsnow(nk) = depthsnow(nk + 1) + dzsSNo(i, j, k, nk) / 2. &
+ +dzsSNo(i, j, k, nk + 1) / 2.
+ enddo
+ do kk = 1, mi
+ if(OutshIB(kk) <= depthsnow(nssSNo(i, j, k))) then
+ agIB(i, j, k, kk) = agsSNo(i, j, k, nssSNo(i, j, k)) &
+ + agIB(i, j, k, kk)
+ g1IB(i, j, k, kk) = g1sSNo(i, j, k, nssSNo(i, j, k)) &
+ + g1IB(i, j, k, kk)
+ g2IB(i, j, k, kk) = g2sSNo(i, j, k, nssSNo(i, j, k)) &
+ + g2IB(i, j, k, kk)
+ roIB(i, j, k, kk) = rosSNo(i, j, k, nssSNo(i, j, k)) &
+ + roIB(i, j, k, kk)
+ tiIB(i, j, k, kk) = tisSNo(i, j, k, nssSNo(i, j, k)) &
+ + tiIB(i, j, k, kk)
+ waIB(i, j, k, kk) = wasSNo(i, j, k, nssSNo(i, j, k)) &
+ + waIB(i, j, k, kk)
+ endif
+ if(OutshIB(kk) >= depthsnow(1)) then
+ agIB(i, j, k, kk) = agsSNo(i, j, k, 1) &
+ + agIB(i, j, k, kk)
+ g1IB(i, j, k, kk) = g1sSNo(i, j, k, 1) &
+ + g1IB(i, j, k, kk)
+ g2IB(i, j, k, kk) = g2sSNo(i, j, k, 1) &
+ + g2IB(i, j, k, kk)
+ roIB(i, j, k, kk) = rosSNo(i, j, k, 1) &
+ + roIB(i, j, k, kk)
+ tiIB(i, j, k, kk) = tisSNo(i, j, k, 1) &
+ + tiIB(i, j, k, kk)
+ waIB(i, j, k, kk) = wasSNo(i, j, k, 1) &
+ + waIB(i, j, k, kk)
+ endif
+ if(OutshIB(kk) > depthsnow(nssSNo(i, j, k)) .and. &
+ OutshIB(kk) < depthsnow(1)) then
+ nk = nssSNo(i, j, k)
+ do WHILE(OutshIB(kk) > depthsnow(nk))
+ nk = nk - 1
+ enddo
+ agIB(i, j, k, kk) = agsSNo(i, j, k, nk + 1) + &
+ (agsSNo(i, j, k, nk) - agsSNo(i, j, k, nk + 1)) / &
+ (depthsnow(nk) - depthsnow(nk + 1)) * (OutshIB(kk) - depthsnow(nk + 1)) &
+ + agIB(i, j, k, kk)
+
+ g1IB(i, j, k, kk) = g1sSNo(i, j, k, nk + 1) + &
+ (g1sSNo(i, j, k, nk) - g1sSNo(i, j, k, nk + 1)) / &
+ (depthsnow(nk) - depthsnow(nk + 1)) * (OutshIB(kk) - depthsnow(nk + 1)) &
+ + g1IB(i, j, k, kk)
+
+ g2IB(i, j, k, kk) = g2sSNo(i, j, k, nk + 1) + &
+ (g2sSNo(i, j, k, nk) - g2sSNo(i, j, k, nk + 1)) / &
+ (depthsnow(nk) - depthsnow(nk + 1)) * (OutshIB(kk) - depthsnow(nk + 1)) &
+ + g2IB(i, j, k, kk)
+
+ tiIB(i, j, k, kk) = tisSNo(i, j, k, nk + 1) + &
+ (tisSNo(i, j, k, nk) - tisSNo(i, j, k, nk + 1)) / &
+ (depthsnow(nk) - depthsnow(nk + 1)) * (OutshIB(kk) - depthsnow(nk + 1)) &
+ + tiIB(i, j, k, kk)
+
+ roIB(i, j, k, kk) = rosSNo(i, j, k, nk + 1) + &
+ (rosSNo(i, j, k, nk) - rosSNo(i, j, k, nk + 1)) / &
+ (depthsnow(nk) - depthsnow(nk + 1)) * (OutshIB(kk) - depthsnow(nk + 1)) &
+ + roIB(i, j, k, kk)
+
+ waIB(i, j, k, kk) = wasSNo(i, j, k, nk + 1) + &
+ (wasSNo(i, j, k, nk) - wasSNo(i, j, k, nk + 1)) / &
+ (depthsnow(nk) - depthsnow(nk + 1)) * (OutshIB(kk) - depthsnow(nk + 1)) &
+ + waIB(i, j, k, kk)
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ do kk = 1, mlhh
+ if(OutdyIB == 1 .and. iterun > 10 .and. timehIB(kk) == 0 .and. ( &
+ jhurGE * 3600 + minuGE * 60 + jsecGE >= (kk) * 86400./real(mlhh) .or. &
+ (jhurGE * 3600 + minuGE * 60 + jsecGE <= dt .and. kk == mlhh))) then
+ timehIB(kk) = jhurGE + real(minuGE) / 100.+real(jsecGE) / 10000.
+ print *, "OUTice x-hourly outputs", kk, timehIB(kk)
+ do j = 1, my
+ do i = 1, mx
+ !C +--------Soil temperature and humidity (slth,slqch)
+ !C + ------------------------------------------
+ ! tmp=0.; slth(i,j,kk)=0.; slqch(i,j,kk)=0.
+ ! do k=1,llx
+ ! tmp(1)=tmp(1)+dz_dSV(k)
+ ! do n=1,nvx ! Sous-mailles (3)
+ ! slth(i,j,kk) = (TsolTV(i,j,n,k) - TfSnow) * dz_dSV(llx-k)
+ ! . * SLsrfl(i,j,n) + slth(i,j,kk)
+ !
+ ! slqch(i,j,kk) = (Eta_TV(i,j,n,k)*1000.* dz_dSV(llx-k))
+ ! . * SLsrfl(i,j,n) + slqch(i,j,kk)
+ !
+ ! end do
+ ! end do
+ ! slth(i,j,kk) = slth(i,j,kk)/tmp(1)
+ ! slqch(i,j,kk) = slqch(i,j,kk)/tmp(1)
+ !
+ !C +--------Convective precipitation (cph)
+ !C + --------------------------------
+ ! cphIB(i,j,kk) = rainCA(i,j) + snowCA(i,j) - cph0IB(i,j)
+ ! cph0IB(i,j) = rainCA(i,j) + snowCA(i,j)
+ ! cphIB(i,j,kk) = cphIB(i,j,kk) * 1000.
+ !C +--------Water Vapor Path (wvph)
+ !C + -----------------------
+ ! wvph(i,j,kk) = 0.
+ ! do k = 2,mz
+ ! tmp(1) = rolvDY(i,j,k)
+ ! . * ((gplvDY(i,j,k-1) + gplvDY(i,j,k )) / 2.
+ ! . - (gplvDY(i,j,k) + gplvDY(i,j,k+1)) / 2.)
+ ! . * grvinv
+ ! wvph(i,j,kk) = wvph(i,j,kk) + qvDY(i,j,k) * 1000.
+ ! . * tmp(1)
+ ! end do
+ !
+ !C +--------Dew Point Temperature (Td)
+ !C + --------------------------
+ ! q = qvDY(i,j,mz)
+ ! qst = qsat0D(tairDY(i,j,mz),sigma(mz),pstDY(i,j),ptopDY,1)
+ ! r = q / max(epsi,1.-q)
+ ! rst = qst / max(epsi,1.-qst)
+ ! rhh = (r/(0.622+r)) / max(epsi,(rst/(0.622+rst))) * 100.
+ ! rhh = max(0.,min(100.,rhh))
+ ! tdh(i,j,kk) = tairDY(i,j,mz) - ((100-rhh)/5.) - 273.15
+ !
+ !C +--------Zenithal variables (ZTD,ZHD,ZWD)
+ !C + --------------------------------
+ ! kUp = 1
+ ! kDown = mz
+ ! kMiddle = (kDown + kUp) / 2.
+ !
+ ! zhdh(i,j,kk)=0 ; zwdh(i,j,kk)=0
+ !
+ ! do i_hi=1,mz-1
+ ! i_lo = i_hi+1.
+ ! refrac_h = k1p / tairDY(i,j,i_lo)
+ ! refrac_w = k2p * qvDY(i,j,i_lo) / (tairDY(i,j,i_lo)**2.
+ ! . * (E+(1.-E)*qvDY(i,j,i_lo)))
+ ! p_hi = (pstDY(i,j) * sigma(i_hi) + ptopDY) * 10.
+ ! p_lo = (pstDY(i,j) * sigma(i_lo) + ptopDY) * 10.
+ !! z_hi = gpmiDY(i,j,i_hi)/grvinv
+ !! z_lo = gpmiDY(i,j,i_lo)/grvinv
+ ! z_hi = gplvDY(i,j,i_hi) * grvinv
+ ! z_lo = gplvDY(i,j,i_lo) * grvinv
+ ! kappa = log(p_lo/p_hi) / (z_hi-z_lo)
+ ! zhdh(i,j,kk) = zhdh(i,j,kk) + refrac_h * (p_lo-p_hi)/kappa
+ ! zwdh(i,j,kk) = zwdh(i,j,kk) + refrac_w * (p_lo-p_hi)/kappa
+ ! end do
+ !
+ ! ztdh(i,j,kk) = zhdh(i,j,kk) + zwdh(i,j,kk)
+ !
+ !
+ !C +--------Weighted Mean Temperature (Tm)
+ !C + ------------------------------
+ ! num=0 ; den=0
+ !
+ ! do i_hi=1,mz-1
+ ! i_lo = i_hi+1.
+ ! refrac_h = qvDY(i,j,i_lo) / (tairDY(i,j,i_lo)
+ ! . * (E+(1.-E)*qvDY(i,j,i_lo)))
+ ! refrac_w = qvDY(i,j,i_lo) / (tairDY(i,j,i_lo)**2.
+ ! . * (E+(1.-E)*qvDY(i,j,i_lo)))
+ ! p_hi = (pstDY(i,j) * sigma(i_hi) + ptopDY) * 10.
+ ! p_lo = (pstDY(i,j) * sigma(i_lo) + ptopDY) * 10.
+ ! z_hi = gplvDY(i,j,i_hi) * grvinv
+ ! z_lo = gplvDY(i,j,i_lo) * grvinv
+ ! kappa = log(p_lo/p_hi) / (z_hi-z_lo)
+ ! num = num + refrac_h * (p_lo-p_hi)/kappa
+ ! den = den + refrac_w * (p_lo-p_hi)/kappa
+ ! end do
+ ! tmh(i,j,kk) = num / den
+ !
+ !C +--------50m-level variables
+ !C + -------------------
+ !
+ ! kz=3
+ ! do k=1,mzuv
+ ! if(OutZUVLevIB(k)==50) kz=k
+ ! end do
+ !
+ ! u5hIB(i,j,kk) = uuzIB_0(i,j,kz)
+ ! v5hIB(i,j,kk) = vvzIB_0(i,j,kz)
+ !
+ ! kz=3
+ ! do k=1,mztq
+ ! if(OutZTQLevIB(k)==50) kz=k
+ ! end do
+ !
+ ! t5hIB(i,j,kk) = ttzIB_0(i,j,kz)-273.15
+ ! q5hIB(i,j,kk) = qqzIB_0(i,j,kz)*1000.
+ ! p5hIB(i,j,kk) = ppzIB_0(i,j,kz)
+ !
+ ! capeh(i,j,kk) = capeCA(i,j)
+ sphIB(i, j, kk) = pstDY(i, j) * 10.
+ sthIB(i, j, kk) = tairsl(i, j) - TfSnow
+ tthIB(i, j, kk) = tairDY(i, j, mz) - TfSnow
+ txhIB(i, j, kk) = txhIB0(i, j); txhIB0(i, j) = -99.
+ tnhIB(i, j, kk) = tnhIB0(i, j); tnhIB0(i, j) = 99.
+ qqhIB(i, j, kk) = qvDY(i, j, mz) * 1000.
+ ! uuhIB(i, j, kk) = (uairDY(i, j, mz-2)+uairDY(i, j, mz-3))/2. ! ~10m
+ ! vvhIB(i, j, kk) = (vairDY(i, j, mz-2)+vairDY(i, j, mz-3))/2. ! ~10m
+ uuhIB(i, j, kk) = uairDY(i, j, mz) ! ~2m
+ vvhIB(i, j, kk) = vairDY(i, j, mz) ! ~2m
+ swdhIB(i, j, kk) = RAdsol(i, j)
+ lwdhIB(i, j, kk) = RAd_ir(i, j)
+ lwuhIB(i, j, kk) = firmSL(i, j)
+ shfhIB(i, j, kk) = (-hsenSL(i, j))
+ lhfhIB(i, j, kk) = (-hlatSL(i, j))
+ alhIB(i, j, kk) = albeSL(i, j)
+ clhIB(i, j, kk) = cld_SL(i, j)
+ snfhIB(i, j, kk) = snowHY(i, j) * 1000.-snfh0IB(i, j)
+ snfh0IB(i, j) = snowHY(i, j) * 1000.
+ prhIB(i, j, kk) = (rainHY(i, j) + snowHY(i, j)) * 1000. &
+ -prh0IB(i, j)
+ prh0IB(i, j) = (rainHY(i, j) + snowHY(i, j)) * 1000.
+ rfhIB(i, j, kk) = max(0., prhIB(i, j, kk) - snfhIB(i, j, kk))
+ mehIB(i, j, kk) = (-1.) * wem_IB(i, j, 1) - meh0IB(i, j)
+ meh0IB(i, j) = (-1.) * wem_IB(i, j, 1)
+ suhIB(i, j, kk) = wee_IB(i, j, 1, 3) - suh0IB(i, j)
+ suh0IB(i, j) = wee_IB(i, j, 1, 3)
+
+ k = 1 ! only snow
+ wet_IB(i, j, k) = 0.
+ do nk = nsno, 1, -1
+ wet_IB(i, j, k) = rosSNo(i, j, k, nk) * dzsSNo(i, j, k, nk) &
+ * 1.d3 / ro_Wat * (1.+0.*wasSNo(i, j, k, nk)) &
+ + wet_IB(i, j, k)
+ enddo
+ wet_IB(i, j, k) = wet_IB(i, j, k) !+ SWaSNo(i,j,k)
+ smbhIB(i, j, kk) = wet_IB(i, j, k) - smbh0IB(i, j)
+ smbh0IB(i, j) = wet_IB(i, j, k)
+
+ swhIB(i, j, kk) = SWaSNo(i, j, k) - swh0IB(i, j)
+ swh0IB(i, j) = SWaSNo(i, j, k)
+
+ ruhIB(i, j, kk) = weu_IB(i, j, k) - ruh0IB(i, j)
+ ruh0IB(i, j) = weu_IB(i, j, k)
+ lwc1mhIB(i, j, kk) = 0.
+ lwc2mhIB(i, j, kk) = 0.
+ nx = 1 ! Sector 1
+ nk = max(1, nssSNo(i, j, nx))
+ depthSNo = dzsSNo(i, j, nx, nk) / 2.
+ do while(depthSNo <= 1. .and. nk > 1)
+ ! 0.1 * ! bug 11/10/2017
+ lwc1mhIB(i, j, kk) = lwc1mhIB(i, j, kk) + &
+ 0.1 * wasSNo(i, j, nx, nk) * &
+ rosSNo(i, j, nx, nk) * dzsSNo(i, j, nx, nk)
+ depthSNo = depthSNo + (dzsSNo(i, j, nx, nk) + dzsSNo(i, j, nx, nk - 1)) / 2.
+ nk = nk - 1
+ enddo
+ nk = max(1, nssSNo(i, j, nx))
+ depthSNo = dzsSNo(i, j, nx, nk) / 2.
+ do while(depthSNo <= 2. .and. nk > 1)
+ ! 0.1 * ! bug 11/10/2017&
+ lwc2mhIB(i, j, kk) = lwc2mhIB(i, j, kk) + &
+ 0.1 * &
+ wasSNo(i, j, nx, nk) * &
+ rosSNo(i, j, nx, nk) * dzsSNo(i, j, nx, nk)
+ depthSNo = depthSNo + &
+ (dzsSNo(i, j, nx, nk) + dzsSNo(i, j, nx, nk - 1)) / 2.
+ nk = nk - 1
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! +--2.2.8 Slush and Superimposed Ice
+ ! + --------------------------------
+
+ ! do k= 1,nsx
+ !
+ ! do j=jp11,my1
+ ! do i=ip11,mx1
+ !
+ ! WKxy1(i,j) = 1.
+ !
+ ! do kk=1,nssSNo(i,j,k)
+ !
+ ! WKxy3(i,j) = max( 0., sign(1., rosSNo(i,j,k,kk)-roCdSV))
+ ! . * max( 0., sign(1.,-wasSNo(i,j,k,kk)+epsi ))
+ !
+ ! WKxy1(i,j) = min( WKxy1(i,j) , WKxy3(i,j)
+ ! . + max( 0., sign(1.,-nsiiIB(i,j,k) +epsi)))
+ !
+ ! nsiiIB (i,j,k) = max(nsiiIB(i,j,k),
+ ! . kk*int(WKxy1(i,j) * WKxy3(i,j)))
+ ! siiceIB(i,j,k) = siiceIB(i,j,k)+dzsSNo(i,j,k,kk)
+ ! . *WKxy1(i,j) * WKxy3(i,j)
+ ! end do
+ !
+ ! siIB (i,j,k) = siiceIB(i,j,k) + siIB(i,j,k)
+ ! slushIB(i,j,k) = 0.
+ ! nsluIB (i,j,k) = nsiiIB(i,j,k)
+ ! end do
+ ! end do
+ ! end do
+ !
+ ! do k= 1,nsx
+ !
+ ! do j=jp11,my1
+ ! do i=ip11,mx1
+ !
+ ! WKxy2(i,j) = 1.
+ !
+ ! do kk=1,nssSNo(i,j,k)
+ ! WKxy3(i,j)= max(0., sign(1., rosSNo(i,j,k,kk)- roCdSV))
+ ! . * max(0., sign(1., wasSNo(i,j,k,kk)- 0.1e0 ))
+ ! . * max(0 , sign(1 , kk-max(1,nsiiIB(i,j,k) )))
+ ! WKxy2(i,j)= min(WKxy2(i,j) , WKxy3(i,j)
+ ! . + max(0., sign(1., nsiiIB(i,j,k)
+ ! . -nsluIB(i,j,k) + epsi)))
+ ! nsluIB (i,j,k) = max(nsluIB(i,j,k),
+ ! . kk*int(WKxy2(i,j)*WKxy3(i,j)))
+ ! slushIB(i,j,k) = slushIB(i,j,k)
+ ! . + dzsSNo(i,j,k,kk)
+ ! . *WKxy2(i,j)*WKxy3(i,j)
+ ! end do
+ !
+ ! suIB (i,j,k) = slushIB(i,j,k) + suIB(i,j,k)
+ ! nsluIB (i,j,k) = nsluIB(i,j,k) - nsiiIB(i,j,k)
+ ! end do
+ ! end do
+ ! end do
+
+ ! + snow (with ice lenses perhaps ! )
+ ! + - - - - - - - -
+ ! + slush (ro > 830kg/m3 and wa > 0.1)
+ ! + - - - - - - - -
+ ! + surimposed ice (ro > 830kg/m3 and wa = 0 )
+ ! + - - - - - - - -
+ ! + ice (ro = 900kg/m3 and wa = 0 )
+ ! + - - - - - - - -
+ ! + ground
+
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! +++ 3. Output ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ if((iterun - itrdIB + nbr_call_outice) >= 43200./real(OutdyIB * dt) .and. &
+ jhurGE * 60 + minuGE >= abs(real(OutdyIB0) - 0.5) * 1440./real(OutdyIB) &
+ .and. &
+ jhurGE * 60 + minuGE < abs(real(OutdyIB0) - 0.5) * 1440./real(OutdyIB) &
+ + nbr_call_outice * dt / 60) then
+
+ iyrrIB = iyrrGE
+ mmarIB = mmarGE
+ jdarIB = jdarGE
+ jhurIB = jhurGE
+ minuIB = minuGE
+
+ endif
+
+ if((iterun - itrdIB + nbr_call_outice) >= 86400./real(OutdyIB * dt) .and. &
+ jhurGE * 60 + minuGE >= OutdyIB0 * 1440./real(OutdyIB) .and. &
+ jhurGE * 60 + minuGE < OutdyIB0 * 1440./real(OutdyIB) &
+ + nbr_call_outice * dt / 60.) then
+
+ !XF WARNING: it does not work if MAR starts at 6h or 12h !!!
+ !XF if it is the case, nbr_call_outice=1 and
+ !XF if ((iterun-itrdIB)*dt+unun.gt.86400.0/real(OutdyIB)) then
+
+ if(dt_ICE2 > iterun - itrdIB) then
+ print *, "OUTice error: dt_ICE2 > iterun-itrdIB", &
+ dt_ICE2, iterun - itrdIB
+ endif
+
+ ! +--3.0 Snapshot of Snow Height
+ ! + ===========================
+
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ zn1IB(i, j, k) = 1.
+ zn2IB(i, j, k) = 0.
+ zn3IB(i, j, k) = 0.
+ wet_IB(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ do kk = nsno, 1, -1
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ zn3IB(i, j, k) = dzsSNo(i, j, k, kk) + zn3IB(i, j, k)
+ wet_IB(i, j, k) = rosSNo(i, j, k, kk) * dzsSNo(i, j, k, kk) &
+ * 1.d3 / ro_Wat * (1.+0.*wasSNo(i, j, k, kk)) &
+ + wet_IB(i, j, k)
+ zn1IB(i, j, k) = zn1IB(i, j, k) &
+ * max(zero, sign(unun, &
+ ro_ice - 20.-rosSNo(i, j, k, kk)))
+ zn2IB(i, j, k) = dzsSNo(i, j, k, kk) * zn1IB(i, j, k) &
+ + zn2IB(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ wet_IB(i, j, k) = wet_IB(i, j, k) + SWaSNo(i, j, k)
+ zn2IB(i, j, k) = zn2IB(i, j, k) * (1.-zn1IB(i, j, k))
+ zn1IB(i, j, k) = zn3IB(i, j, k) - zn0IB(i, j, k)
+ mbIB(i, j, k) = wet_IB(i, j, k) - mb0IB(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ ! +--3.1 Computation of Averaged Values
+ ! + ==================================
+ qbrIB(i, j) = qbrIB(i, j) / real(dt_ICE2)
+ pddIB(i, j) = pddIB(i, j) / real(dt_ICE2)
+ do kk = 1, ml
+ ttIB(i, j, kk) = ttIB(i, j, kk) / real(dt_ICE2)
+ tdIB(i, j, kk) = tdIB(i, j, kk) / real(dt_ICE2)
+ uuIB(i, j, kk) = uuIB(i, j, kk) / real(dt_ICE2)
+ vvIB(i, j, kk) = vvIB(i, j, kk) / real(dt_ICE2)
+ if(track_wind) then
+ do itw = 1, ntrackwind
+ duIB(i, j, kk, itw) = duIB(i, j, kk, itw) / real(dt_ICE2)
+ dvIB(i, j, kk, itw) = dvIB(i, j, kk, itw) / real(dt_ICE2)
+ enddo
+ endif
+ if(track_dgz) then
+ do itw = 1, ntrackdgz
+ dudgzIB(i, j, kk, itw) = dudgzIB(i, j, kk, itw) / real(dt_ICE2)
+ dvdgzIB(i, j, kk, itw) = dvdgzIB(i, j, kk, itw) / real(dt_ICE2)
+ enddo
+ endif
+ uvIB(i, j, kk) = uvIB(i, j, kk) / real(dt_ICE2)
+ wwIB(i, j, kk) = wwIB(i, j, kk) / real(dt_ICE2)
+ psigIB(i, j, kk) = psigIB(i, j, kk) / real(dt_ICE2)
+ wsigIB(i, j, kk) = wsigIB(i, j, kk) / real(dt_ICE2)
+ ruuIB(i, j, kk) = ruuIB(i, j, kk) / real(dt_ICE2)
+ rvvIB(i, j, kk) = rvvIB(i, j, kk) / real(dt_ICE2)
+ ruvIB(i, j, kk) = ruvIB(i, j, kk) / real(dt_ICE2)
+ qqIB(i, j, kk) = qqIB(i, j, kk) / real(dt_ICE2)
+ if(track_water) then
+ do jtw = 1, ntwater
+ dqvIB(i, j, kk, jtw) = dqvIB(i, j, kk, jtw) / real(dt_ICE2)
+ enddo
+ endif
+ rhodzIB(i, j, kk) = rhodzIB(i, j, kk) / real(dt_ICE2)
+ rolvIB(i, j, kk) = rolvIB(i, j, kk) / real(dt_ICE2)
+ rhIB(i, j, kk) = rhIB(i, j, kk) / real(dt_ICE2)
+ zzIB(i, j, kk) = zzIB(i, j, kk) / real(dt_ICE2)
+ tkeIB(i, j, kk) = tkeIB(i, j, kk) / real(dt_ICE2)
+ lqsIB(i, j, kk) = lqsIB(i, j, kk) / real(dt_ICE2)
+ lqiIB(i, j, kk) = lqiIB(i, j, kk) / real(dt_ICE2)
+ lqrIB(i, j, kk) = lqrIB(i, j, kk) / real(dt_ICE2)
+ lqwIB(i, j, kk) = lqwIB(i, j, kk) / real(dt_ICE2)
+ qsbIB(i, j, kk) = qsbIB(i, j, kk) / real(dt_ICE2)
+ lsbIB(i, j, kk) = lsbIB(i, j, kk) / real(dt_ICE2)
+ swn3DIB(i, j, kk) = swn3DIB(i, j, kk) / real(dt_ICE2)
+ lwn3DIB(i, j, kk) = lwn3DIB(i, j, kk) / real(dt_ICE2)
+ swnc3DIB(i, j, kk) = swnc3DIB(i, j, kk) / real(dt_ICE2)
+ lwnc3DIB(i, j, kk) = lwnc3DIB(i, j, kk) / real(dt_ICE2)
+ cod3DIB(i, j, kk) = cod3DIB(i, j, kk) / real(dt_ICE2)
+ cc3DIB(i, j, kk) = cc3DIB(i, j, kk) / real(dt_ICE2)
+ enddo
+ do kp = 1, mp
+ if(nbpIB(i, j, kp) > 0) then
+ ttpIB(i, j, kp) = ttpIB(i, j, kp) / nbpIB(i, j, kp)
+ uupIB(i, j, kp) = uupIB(i, j, kp) / nbpIB(i, j, kp)
+ vvpIB(i, j, kp) = vvpIB(i, j, kp) / nbpIB(i, j, kp)
+ wwpIB(i, j, kp) = wwpIB(i, j, kp) / nbpIB(i, j, kp)
+ uvpIB(i, j, kp) = uvpIB(i, j, kp) / nbpIB(i, j, kp)
+ qqpIB(i, j, kp) = qqpIB(i, j, kp) / nbpIB(i, j, kp)
+ zzpIB(i, j, kp) = zzpIB(i, j, kp) / nbpIB(i, j, kp)
+ else
+ ttpIB(i, j, kp) = NF_FILL_REAL
+ uupIB(i, j, kp) = NF_FILL_REAL
+ vvpIB(i, j, kp) = NF_FILL_REAL
+ wwpIB(i, j, kp) = NF_FILL_REAL
+ uvpIB(i, j, kp) = NF_FILL_REAL
+ qqpIB(i, j, kp) = NF_FILL_REAL
+ zzpIB(i, j, kp) = NF_FILL_REAL
+ endif
+ enddo
+ do kz = 1, mztq
+ ttzIB(i, j, kz) = ttzIB(i, j, kz) / real(dt_ICE2)
+ rhzIB(i, j, kz) = rhzIB(i, j, kz) / real(dt_ICE2)
+ qqzIB(i, j, kz) = qqzIB(i, j, kz) / real(dt_ICE2)
+ enddo
+ do kz = 1, mzuv
+ uuzIB(i, j, kz) = uuzIB(i, j, kz) / real(dt_ICE2)
+ vvzIB(i, j, kz) = vvzIB(i, j, kz) / real(dt_ICE2)
+ u2zIB(i, j, kz) = u2zIB(i, j, kz) / real(dt_ICE2)
+ v2zIB(i, j, kz) = v2zIB(i, j, kz) / real(dt_ICE2)
+ uvzIB(i, j, kz) = uvzIB(i, j, kz) / real(dt_ICE2)
+ rozIB(i, j, kz) = rozIB(i, j, kz) / real(dt_ICE2)
+ enddo
+ do k = 1, nsx
+ pblIB(i, j, k) = pblIB(i, j, k) / real(dt_ICE2)
+ al1IB(i, j, k) = al1IB(i, j, k) / max(swdIB(i, j), epsi)
+ al2IB(i, j, k) = al2IB(i, j, k) / real(dt_ICE2)
+ enddo
+ alIB(i, j) = alIB(i, j) / real(dt_ICE2)
+ as1_IB(i, j) = as1_IB(i, j) / real(dt_ICE2)
+ as2_IB(i, j) = as2_IB(i, j) / real(dt_ICE2)
+ as3_IB(i, j) = as3_IB(i, j) / real(dt_ICE2)
+ swdIB(i, j) = swdIB(i, j) / real(dt_ICE2)
+ swuIB(i, j) = swuIB(i, j) / real(dt_ICE2)
+ lwdIB(i, j) = lwdIB(i, j) / real(dt_ICE2)
+ lwuIB(i, j) = lwuIB(i, j) / real(dt_ICE2)
+ swdtIB(i, j) = swdtIB(i, j) / real(dt_ICE2)
+ swutIB(i, j) = swutIB(i, j) / real(dt_ICE2)
+ lwutIB(i, j) = lwutIB(i, j) / real(dt_ICE2)
+ shfIB(i, j) = shfIB(i, j) / real(dt_ICE2)
+ lhfIB(i, j) = lhfIB(i, j) / real(dt_ICE2)
+ spIB(i, j) = spIB(i, j) / real(dt_ICE2)
+ slpIB(i, j) = slpIB(i, j) / real(dt_ICE2)
+ if(mw == 5) then
+ gradTIB(i, j) = gradTIB(i, j) / real(dt_ICE2) !*CL*
+ gradQIB(i, j) = gradQIB(i, j) / real(dt_ICE2) !*CL*
+ endif
+ ccIB(i, j) = ccIB(i, j) / real(dt_ICE2)
+ cuIB(i, j) = cuIB(i, j) / real(dt_ICE2)
+ cmIB(i, j) = cmIB(i, j) / real(dt_ICE2)
+ cdIB(i, j) = cdIB(i, j) / real(dt_ICE2)
+ qwIB(i, j) = qwIB(i, j) / real(dt_ICE2)
+ qiIB(i, j) = qiIB(i, j) / real(dt_ICE2)
+ qsIB(i, j) = qsIB(i, j) / real(dt_ICE2)
+ qrIB(i, j) = qrIB(i, j) / real(dt_ICE2)
+ wvpIB(i, j) = wvpIB(i, j) / real(dt_ICE2)
+ cwpIB(i, j) = cwpIB(i, j) / real(dt_ICE2)
+ iwpIB(i, j) = iwpIB(i, j) / real(dt_ICE2)
+ tcwvIB(i, j) = tcwvIB(i, j) / real(dt_ICE2) ! cCA : new
+ tclcIB(i, j) = tclcIB(i, j) / real(dt_ICE2) ! cCA : new
+ tcicIB(i, j) = tcicIB(i, j) / real(dt_ICE2) ! cCA : new
+ tclpIB(i, j) = tclpIB(i, j) / real(dt_ICE2) ! cCA : new
+ tcipIB(i, j) = tcipIB(i, j) / real(dt_ICE2) ! cCA : new
+ codIB(i, j) = codIB(i, j) / real(dt_ICE2)
+ stIB(i, j) = stIB(i, j) / real(dt_ICE2)
+ sicIB(i, j) = sicIB(i, j) / real(dt_ICE2)
+ if(coupling_ao .eqv. .true.) then
+ sicaoIB(i, j) = sicaoIB(i, j) / real(dt_ICE2)
+ sitaoIB(i, j) = sitaoIB(i, j) / real(dt_ICE2)
+ sntaoIB(i, j) = sntaoIB(i, j) / real(dt_ICE2)
+ do k = 1, nsx
+ st2aoIB(i, j, k) = st2aoIB(i, j, k) / real(dt_ICE2)
+ albaoIB(i, j, k) = albaoIB(i, j, k) / real(dt_ICE2)
+ enddo
+ endif
+
+ do k = 1, nsx
+ frvIB(i, j, k) = frvIB(i, j, k) / real(dt_ICE2)
+ st2IB(i, j, k) = st2IB(i, j, k) / real(dt_ICE2)
+ z0IB(i, j, k) = z0IB(i, j, k) / real(dt_ICE2)
+ r0IB(i, j, k) = r0IB(i, j, k) / real(dt_ICE2)
+ uusIB(i, j, k) = uusIB(i, j, k) / real(dt_ICE2)
+ uusthIB(i, j, k) = uusthIB(i, j, k) / real(dt_ICE2)
+ utsIB(i, j, k) = utsIB(i, j, k) / real(dt_ICE2)
+ uqsIB(i, j, k) = uqsIB(i, j, k) / real(dt_ICE2)
+ ussIB(i, j, k) = ussIB(i, j, k) / real(dt_ICE2)
+ if(mw == 5) then
+ tt_intIB(i, j, k) = tt_intIB(i, j, k) / real(dt_ICE2) !*CL*
+ qq_intIB(i, j, k) = qq_intIB(i, j, k) / real(dt_ICE2) !*CL*
+ endif
+ do kk = 1, llx
+ sltIB(i, j, k, kk) = sltIB(i, j, k, kk) / real(dt_ICE2)
+ slqIB(i, j, k, kk) = slqIB(i, j, k, kk) / real(dt_ICE2)
+ enddo
+ do kk = 1, mi
+ agIB(i, j, k, kk) = agIB(i, j, k, kk) / real(dt_ICE2)
+ g1IB(i, j, k, kk) = g1IB(i, j, k, kk) / real(dt_ICE2)
+ g2IB(i, j, k, kk) = g2IB(i, j, k, kk) / real(dt_ICE2)
+ roIB(i, j, k, kk) = roIB(i, j, k, kk) / real(dt_ICE2)
+ tiIB(i, j, k, kk) = tiIB(i, j, k, kk) / real(dt_ICE2) - TfSnow
+ waIB(i, j, k, kk) = waIB(i, j, k, kk) / real(dt_ICE2)
+ enddo
+ enddo
+
+ enddo
+ enddo
+
+ dt_ICE2 = -1
+
+ ! + 3.2 Save in a netcdf file
+ ! + =========================
+
+ dt_ICE = dt_ICE + 1
+
+ if(iterun > 1) then !
+
+ ! + ************
+ call UNwopen(fnamNC_tmp, ID__nc_ice)
+ ! + ************
+
+ ENDif ! Re-Open file if already created.
+
+ write(6, 398) trim(fnamNC_tmp), &
+ jdarGE, mmarGE, iyrrGE, jhurGE, minuGE, jsecGE
+
+398 format(' Writing of OUTice in ', a19, ':' &
+ , i2, '/', i2, '/', i4, ' ', i2, ':', i2, ':', i2)
+
+ ! +--3.2.1 Write Time-dependent variables
+ ! + ------------------------------------
+
+ if(nDFdim(0) == 0) then !
+
+ ! date = (351+(iyrrGE -1902) *365 ! Nb Days before iyrrGE
+ ! . +(iyrrGE -1901) / 4 ! Nb Leap Years
+ ! . + njyrGE(mmarGE) ! Nb Days before mmarGE
+ ! . + njybGE(mmarGE) ! (including Leap Day)
+ ! . * max(0,1-mod(iyrrGE,4)) !
+ ! . + jdarGE -1 )* 24 !
+ ! . + jhurGE !
+ ! . +(minuGE *60 +jsecGE)/3600 !
+
+ date = nint(real(itexpe) * dt / 60.)
+ if(OutdyIB <= 24) date = nint(real(itexpe) * dt / (3600.))
+ if(OutdyIB == 1) date = nint(real(itexpe) * dt / (3600.*24.))
+
+ dater = real(date0 + date) / 2.
+ date0 = date
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'time', dt_ICE, 1, 1, 1, dater)
+ ! + ************
+
+ endif
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'DATE', dt_ICE, 1, 1, 1, &
+ dateNC_ice(dt_ICE))
+ call UNwrite(ID__nc_ice, 'year', dt_ICE, 1, 1, 1, &
+ yearNC_ice(dt_ICE))
+ ! + ************
+
+ if(iyrrIB == 0 .or. OutdyIB > 1) then
+ iyrrIB = iyrrGE
+ mmarIB = mmarGE
+ jdarIB = jdarGE
+ jhurIB = jhurGE
+ minuIB = minuGE
+ endif
+
+ ! + ************
+ dater = iyrrIB
+ call UNwrite(ID__nc_ice, 'YYYY', dt_ICE, 1, 1, 1, dater)
+ dater = mmarIB
+ call UNwrite(ID__nc_ice, 'MM', dt_ICE, 1, 1, 1, dater)
+ dater = jdarIB
+ call UNwrite(ID__nc_ice, 'DD', dt_ICE, 1, 1, 1, dater)
+ dater = jhurIB
+ call UNwrite(ID__nc_ice, 'HH', dt_ICE, 1, 1, 1, dater)
+ dater = minuIB
+ call UNwrite(ID__nc_ice, 'MIN', dt_ICE, 1, 1, 1, dater)
+ ! + ************
+
+ ! +--3.2.0.a X-hourly Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ if(OutdyIB == 1) then
+ ! + ************
+ call UNwrite(ID__nc_ice, 'TIMEh', dt_ICE, mlhh, 1, 1, timehIB)
+ call UNwrite(ID__nc_ice, 'SPh', dt_ICE, mx, my, mlhh, sphIB)
+ call UNwrite(ID__nc_ice, 'STh', dt_ICE, mx, my, mlhh, sthIB)
+ call UNwrite(ID__nc_ice, 'TTh', dt_ICE, mx, my, mlhh, tthIB)
+ call UNwrite(ID__nc_ice, 'TXh', dt_ICE, mx, my, mlhh, txhIB)
+ call UNwrite(ID__nc_ice, 'TNh', dt_ICE, mx, my, mlhh, tnhIB)
+ call UNwrite(ID__nc_ice, 'QQh', dt_ICE, mx, my, mlhh, qqhIB)
+ call UNwrite(ID__nc_ice, 'UUh', dt_ICE, mx, my, mlhh, uuhIB)
+ call UNwrite(ID__nc_ice, 'VVh', dt_ICE, mx, my, mlhh, vvhIB)
+ call UNwrite(ID__nc_ice, 'SWDh', dt_ICE, mx, my, mlhh, swdhIB)
+ call UNwrite(ID__nc_ice, 'LWDh', dt_ICE, mx, my, mlhh, lwdhIB)
+ call UNwrite(ID__nc_ice, 'LWUh', dt_ICE, mx, my, mlhh, lwuhIB)
+ call UNwrite(ID__nc_ice, 'SHFh', dt_ICE, mx, my, mlhh, shfhIB)
+ call UNwrite(ID__nc_ice, 'LHFh', dt_ICE, mx, my, mlhh, lhfhIB)
+ call UNwrite(ID__nc_ice, 'ALh', dt_ICE, mx, my, mlhh, alhIB)
+ call UNwrite(ID__nc_ice, 'CCh', dt_ICE, mx, my, mlhh, clhIB)
+ call UNwrite(ID__nc_ice, 'LWC1mh', dt_ICE, mx, my, mlhh, lwc1mhIB)
+ call UNwrite(ID__nc_ice, 'LWC2mh', dt_ICE, mx, my, mlhh, lwc2mhIB)
+
+ ! call UNwrite (ID__nc_ice,'TT50mh',dt_ICE,mx, my, mlhh,t5hIB)
+ ! call UNwrite (ID__nc_ice,'QQ50mh',dt_ICE,mx, my, mlhh,q5hIB)
+ ! call UNwrite (ID__nc_ice,'UU50mh',dt_ICE,mx, my, mlhh,u5hIB)
+ ! call UNwrite (ID__nc_ice,'VV50mh',dt_ICE,mx, my, mlhh,v5hIB)
+ ! call UNwrite (ID__nc_ice,'PP50mh',dt_ICE,mx, my, mlhh,p5hIB)
+ !
+ ! call UNwrite (ID__nc_ice, 'TDh', dt_ICE, mx, my, mlhh,tdh)
+ ! call UNwrite (ID__nc_ice, 'SLTh', dt_ICE, mx, my, mlhh,slth)
+ ! call UNwrite (ID__nc_ice,'SLQCh', dt_ICE, mx, my, mlhh,slqch)
+ ! call UNwrite (ID__nc_ice, 'WVPh', dt_ICE, mx, my, mlhh,wvph)
+ ! call UNwrite (ID__nc_ice, 'CPh', dt_ICE, mx, my, mlhh,cphIB)
+ ! call UNwrite (ID__nc_ice, 'CAPEh',dt_ICE, mx, my, mlhh,capeh)
+ ! call UNwrite (ID__nc_ice, 'WMTh', dt_ICE, mx, my, mlhh,tmh)
+ ! call UNwrite (ID__nc_ice, 'ZTDh', dt_ICE, mx, my, mlhh,ztdh)
+ ! call UNwrite (ID__nc_ice, 'ZHDh', dt_ICE, mx, my, mlhh,zhdh)
+ ! call UNwrite (ID__nc_ice, 'ZWDh', dt_ICE, mx, my, mlhh,zwdh)
+ endif
+
+ ! + ************
+
+ ! +--3.2.1.a Atmospheric Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! ! daily mean
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'TTmin', dt_ICE, mx, my, ml, mintIB)
+ call UNwrite(ID__nc_ice, 'TTmax', dt_ICE, mx, my, ml, maxtIB)
+ call UNwrite(ID__nc_ice, 'TTint', dt_ICE, mx, my, nsx, tt_intIB)
+ call UNwrite(ID__nc_ice, 'TT', dt_ICE, mx, my, ml, ttIB)
+ CALL UNwrite(ID__nc_ice, 'TD', dt_ICE, mx, my, ml, tdIB)
+ call UNwrite(ID__nc_ice, 'UU', dt_ICE, mx, my, ml, uuIB)
+ call UNwrite(ID__nc_ice, 'VV', dt_ICE, mx, my, ml, vvIB)
+ if(track_wind) then
+ do itw = 1, ntrackwind
+ call UNwrite(ID__nc_ice, 'du_'//name_wind(itw), dt_ICE, mx, my, ml, duIB(:, :, :, itw))
+ call UNwrite(ID__nc_ice, 'dv_'//name_wind(itw), dt_ICE, mx, my, ml, dvIB(:, :, :, itw))
+ enddo
+ endif
+ if(track_dgz) then
+ do itw = 1, ntrackdgz
+ call UNwrite(ID__nc_ice, 'du_'//name_dgz(itw), dt_ICE, mx, my, ml, dudgzIB(:, :, :, itw))
+ call UNwrite(ID__nc_ice, 'dv_'//name_dgz(itw), dt_ICE, mx, my, ml, dvdgzIB(:, :, :, itw))
+ enddo
+ endif
+ call UNwrite(ID__nc_ice, 'UV', dt_ICE, mx, my, ml, uvIB)
+ call UNwrite(ID__nc_ice, 'UVmax', dt_ICE, mx, my, ml, maxwIB)
+ call UNwrite(ID__nc_ice, 'WW', dt_ICE, mx, my, ml, wwIB)
+ call UNwrite(ID__nc_ice, 'psig', dt_ICE, mx, my, ml, psigIB)
+ call UNwrite(ID__nc_ice, 'wsig', dt_ICE, mx, my, ml, wsigIB)
+ call UNwrite(ID__nc_ice, 'XUU', dt_ICE, mx, my, ml, ruuIB)
+ call UNwrite(ID__nc_ice, 'YVV', dt_ICE, mx, my, ml, rvvIB)
+ call UNwrite(ID__nc_ice, 'YUU', dt_ICE, mx, my, ml, rvvIB)
+ call UNwrite(ID__nc_ice, 'XYUV', dt_ICE, mx, my, ml, ruvIB)
+ call UNwrite(ID__nc_ice, 'XUV', dt_ICE, mx, my, ml, ruvIB)
+ call UNwrite(ID__nc_ice, 'QQ', dt_ICE, mx, my, ml, qqIB)
+ if(track_water) then
+ do jtw = 1, ntwater
+ call UNwrite(ID__nc_ice, 'dq_'//name_water(jtw), dt_ICE, mx, my, ml, dqvIB(:, :, :, jtw))
+ enddo
+ endif
+ call UNwrite(ID__nc_ice, 'QQint', dt_ICE, mx, my, nsx, qq_intIB)
+ call UNwrite(ID__nc_ice, 'RHO', dt_ICE, mx, my, ml, rolvIB)
+ call UNwrite(ID__nc_ice, 'RH', dt_ICE, mx, my, ml, rhIB)
+ call UNwrite(ID__nc_ice, 'ZZ', dt_ICE, mx, my, ml, zzIB)
+ call UNwrite(ID__nc_ice, 'PDD', dt_ICE, mx, my, 1, pddIB)
+ call UNwrite(ID__nc_ice, 'SP', dt_ICE, mx, my, 1, spIB)
+ call UNwrite(ID__nc_ice, 'SLP', dt_ICE, mx, my, 1, slpIB)
+ call UNwrite(ID__nc_ice, 'gradT', dt_ICE, mx, my, 1, gradTIB)
+ call UNwrite(ID__nc_ice, 'gradTmin', dt_ICE, mx, my, 1, mingrTIB)
+ call UNwrite(ID__nc_ice, 'gradTmax', dt_ICE, mx, my, 1, maxgrTIB)
+ call UNwrite(ID__nc_ice, 'gradQ', dt_ICE, mx, my, 1, gradQIB)
+ call UNwrite(ID__nc_ice, 'gradQmin', dt_ICE, mx, my, 1, mingrQIB)
+ call UNwrite(ID__nc_ice, 'gradQmax', dt_ICE, mx, my, 1, maxgrQIB)
+ call UNwrite(ID__nc_ice, 'TKE', dt_ICE, mx, my, ml, tkeIB)
+ call UNwrite(ID__nc_ice, 'LQS', dt_ICE, mx, my, ml, lqsIB)
+ call UNwrite(ID__nc_ice, 'LQI', dt_ICE, mx, my, ml, lqiIB)
+ call UNwrite(ID__nc_ice, 'LQR', dt_ICE, mx, my, ml, lqrIB)
+ call UNwrite(ID__nc_ice, 'LQW', dt_ICE, mx, my, ml, lqwIB)
+ call UNwrite(ID__nc_ice, 'SWN3D', dt_ICE, mx, my, ml, swn3DIB)
+ call UNwrite(ID__nc_ice, 'LWN3D', dt_ICE, mx, my, ml, lwn3DIB)
+ call UNwrite(ID__nc_ice, 'SWNC3D', dt_ICE, mx, my, ml, swnc3DIB)
+ call UNwrite(ID__nc_ice, 'LWNC3D', dt_ICE, mx, my, ml, lwnc3DIB)
+ call UNwrite(ID__nc_ice, 'COD3D', dt_ICE, mx, my, ml, cod3DIB)
+ call UNwrite(ID__nc_ice, 'CC3D', dt_ICE, mx, my, ml, cc3DIB)
+
+ ttbIB = ttIB(:, :, 1:mlb)
+ txbIB = maxtIB(:, :, 1:mlb)
+ tnbIB = mintIB(:, :, 1:mlb)
+ qqbIB = qqIB(:, :, 1:mlb)
+ uubIB = uuIB(:, :, 1:mlb)
+ vvbIB = vvIB(:, :, 1:mlb)
+ uvbIB = uvIB(:, :, 1:mlb)
+ zzbIB = zzIB(:, :, 1:mlb)
+
+ call UNwrite(ID__nc_ice, 'TTb', dt_ICE, mx, my, mlb, ttbIB)
+ call UNwrite(ID__nc_ice, 'TXb', dt_ICE, mx, my, mlb, txbIB)
+ call UNwrite(ID__nc_ice, 'TNb', dt_ICE, mx, my, mlb, tnbIB)
+ call UNwrite(ID__nc_ice, 'QQb', dt_ICE, mx, my, mlb, qqbIB)
+ call UNwrite(ID__nc_ice, 'ZZb', dt_ICE, mx, my, mlb, zzbIB)
+ call UNwrite(ID__nc_ice, 'UUb', dt_ICE, mx, my, mlb, uubIB)
+ call UNwrite(ID__nc_ice, 'VVb', dt_ICE, mx, my, mlb, vvbIB)
+ call UNwrite(ID__nc_ice, 'UVb', dt_ICE, mx, my, mlb, uvbIB)
+
+ call UNwrite(ID__nc_ice, 'TTp', dt_ICE, mx, my, mp, ttpIB)
+ call UNwrite(ID__nc_ice, 'QQp', dt_ICE, mx, my, mp, qqpIB)
+ call UNwrite(ID__nc_ice, 'ZZp', dt_ICE, mx, my, mp, zzpIB)
+ call UNwrite(ID__nc_ice, 'UUp', dt_ICE, mx, my, mp, uupIB)
+ call UNwrite(ID__nc_ice, 'VVp', dt_ICE, mx, my, mp, vvpIB)
+ call UNwrite(ID__nc_ice, 'WWp', dt_ICE, mx, my, mp, wwpIB)
+ call UNwrite(ID__nc_ice, 'UVp', dt_ICE, mx, my, mp, uvpIB)
+
+ call UNwrite(ID__nc_ice, 'TTz', dt_ICE, mx, my, mztq, ttzIB)
+ call UNwrite(ID__nc_ice, 'QQz', dt_ICE, mx, my, mztq, qqzIB)
+ call UNwrite(ID__nc_ice, 'RHz', dt_ICE, mx, my, mztq, rhzIB)
+ call UNwrite(ID__nc_ice, 'UUz', dt_ICE, mx, my, mzuv, uuzIB)
+ call UNwrite(ID__nc_ice, 'VVz', dt_ICE, mx, my, mzuv, vvzIB)
+ CALL UNwrite(ID__nc_ice, 'U2z', dt_ICE, mx, my, mzuv, u2zIB)
+ CALL UNwrite(ID__nc_ice, 'V2z', dt_ICE, mx, my, mzuv, v2zIB)
+ call UNwrite(ID__nc_ice, 'UVz', dt_ICE, mx, my, mzuv, uvzIB)
+ call UNwrite(ID__nc_ice, 'ROz', dt_ICE, mx, my, mzuv, rozIB)
+ ! + ************
+
+ ! +--3.2.1.b Surface Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! ! daily mean
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'SWD', dt_ICE, mx, my, 1, swdIB)
+ call UNwrite(ID__nc_ice, 'SWU', dt_ICE, mx, my, 1, swuIB)
+ call UNwrite(ID__nc_ice, 'SUN', dt_ICE, mx, my, 1, sunIB)
+ call UNwrite(ID__nc_ice, 'LWD', dt_ICE, mx, my, 1, lwdIB)
+ call UNwrite(ID__nc_ice, 'LWU', dt_ICE, mx, my, 1, lwuIB)
+
+ call UNwrite(ID__nc_ice, 'SWDT', dt_ICE, mx, my, 1, swdtIB)
+ call UNwrite(ID__nc_ice, 'SWUT', dt_ICE, mx, my, 1, swutIB)
+ call UNwrite(ID__nc_ice, 'LWUT', dt_ICE, mx, my, 1, lwutIB)
+
+ call UNwrite(ID__nc_ice, 'SHF', dt_ICE, mx, my, 1, shfIB)
+ call UNwrite(ID__nc_ice, 'LHF', dt_ICE, mx, my, 1, lhfIB)
+ call UNwrite(ID__nc_ice, 'AL', dt_ICE, mx, my, 1, alIB)
+ call UNwrite(ID__nc_ice, 'AS1', dt_ICE, mx, my, 1, aS1_IB)
+ call UNwrite(ID__nc_ice, 'AS2', dt_ICE, mx, my, 1, aS2_IB)
+ call UNwrite(ID__nc_ice, 'AS3', dt_ICE, mx, my, 1, aS3_IB)
+ call UNwrite(ID__nc_ice, 'AL1', dt_ICE, mx, my, nsx, al1IB)
+ call UNwrite(ID__nc_ice, 'AL2', dt_ICE, mx, my, nsx, al2IB)
+ call UNwrite(ID__nc_ice, 'FRV2', dt_ICE, mx, my, nsx, frvIB)
+ call UNwrite(ID__nc_ice, 'SIC', dt_ICE, mx, my, 1, sicIB)
+ call UNwrite(ID__nc_ice, 'FRA', dt_ICE, mx, my, nsx, frvIB)
+ call UNwrite(ID__nc_ice, 'ST', dt_ICE, mx, my, 1, stIB)
+ call UNwrite(ID__nc_ice, 'ST2', dt_ICE, mx, my, nsx, st2IB)
+ call UNwrite(ID__nc_ice, 'Z0', dt_ICE, mx, my, nsx, Z0IB)
+ call UNwrite(ID__nc_ice, 'R0', dt_ICE, mx, my, nsx, R0IB)
+ call UNwrite(ID__nc_ice, 'UUS', dt_ICE, mx, my, nsx, UUSIB)
+ call UNwrite(ID__nc_ice, 'UUSTH', dt_ICE, mx, my, nsx, UUSTHIB)
+ call UNwrite(ID__nc_ice, 'UTS', dt_ICE, mx, my, nsx, UTSIB)
+ call UNwrite(ID__nc_ice, 'UQS', dt_ICE, mx, my, nsx, UQSIB)
+ call UNwrite(ID__nc_ice, 'USS', dt_ICE, mx, my, nsx, USSIB)
+ call UNwrite(ID__nc_ice, 'PBL', dt_ICE, mx, my, nsx, pblIB)
+ ! + ++++++++++++
+ call UNwrite(ID__nc_ice, 'SICAO', dt_ICE, mx, my, 1, sicaoIB)
+ call UNwrite(ID__nc_ice, 'SITAO', dt_ICE, mx, my, 1, sitaoIB)
+ call UNwrite(ID__nc_ice, 'SNTAO', dt_ICE, mx, my, 1, sntaoIB)
+ call UNwrite(ID__nc_ice, 'ST2AO', dt_ICE, mx, my, nsx, st2aoIB)
+ call UNwrite(ID__nc_ice, 'AL2AO', dt_ICE, mx, my, nsx, albaoIB)
+
+ ! +--3.2.1.c Cloud Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! ! daily mean
+
+ ! + ++++++++++++
+ call UNwrite(ID__nc_ice, 'CC', dt_ICE, mx, my, 1, ccIB)
+ call UNwrite(ID__nc_ice, 'CU', dt_ICE, mx, my, 1, cuIB)
+ call UNwrite(ID__nc_ice, 'CM', dt_ICE, mx, my, 1, cmIB)
+ call UNwrite(ID__nc_ice, 'CD', dt_ICE, mx, my, 1, cdIB)
+ call UNwrite(ID__nc_ice, 'QW', dt_ICE, mx, my, 1, qwIB)
+ call UNwrite(ID__nc_ice, 'QI', dt_ICE, mx, my, 1, qiIB)
+ call UNwrite(ID__nc_ice, 'QS', dt_ICE, mx, my, 1, qsIB)
+ call UNwrite(ID__nc_ice, 'QR', dt_ICE, mx, my, 1, qrIB)
+ call UNwrite(ID__nc_ice, 'COD', dt_ICE, mx, my, 1, codIB)
+ call UNwrite(ID__nc_ice, 'WVP', dt_ICE, mx, my, 1, wvpIB)
+ call UNwrite(ID__nc_ice, 'CWP', dt_ICE, mx, my, 1, cwpIB)
+ call UNwrite(ID__nc_ice, 'IWP', dt_ICE, mx, my, 1, iwpIB)
+ call UNwrite(ID__nc_ice, 'QBR', dt_ICE, mx, my, 1, qbrIB)
+ call UNwrite(ID__nc_ice, 'tcwv', dt_ICE, mx, my, 1, tcwvIB)
+ call UNwrite(ID__nc_ice, 'tclc', dt_ICE, mx, my, 1, tclcIB)
+ call UNwrite(ID__nc_ice, 'tcic', dt_ICE, mx, my, 1, tcicIB)
+ call UNwrite(ID__nc_ice, 'tclp', dt_ICE, mx, my, 1, tclpIB)
+ call UNwrite(ID__nc_ice, 'tcip', dt_ICE, mx, my, 1, tcipIB)
+ call UNwrite(ID__nc_ice, 'rhodz', dt_ICE, mx, my, ml, rhodzIB)
+ ! + ++++++++++++
+
+ ! +--3.2.1.d Snow Pack Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ do k = 1, nsx
+
+ write(sector, '(i1)') k
+
+ do kk = 1, mi
+ do j = 1, my
+ do i = 1, mx
+ xymi1(i, j, kk) = g1IB(i, j, k, kk)
+ xymi2(i, j, kk) = g2IB(i, j, k, kk)
+ xymi3(i, j, kk) = agIB(i, j, k, kk)
+ xymi5(i, j, kk) = roIB(i, j, k, kk)
+ xymi6(i, j, kk) = tiIB(i, j, k, kk)
+ xymi7(i, j, kk) = waIB(i, j, k, kk)
+ enddo
+ enddo
+ enddo
+
+ ! ! daily mean
+
+ ! + ++++++++++++
+ call UNwrite(ID__nc_ice, 'AG'//sector, &
+ dt_ICE, mx, my, mi, xymi3)
+ call UNwrite(ID__nc_ice, 'G1'//sector, &
+ dt_ICE, mx, my, mi, xymi1)
+ call UNwrite(ID__nc_ice, 'G2'//sector, &
+ dt_ICE, mx, my, mi, xymi2)
+ call UNwrite(ID__nc_ice, 'RO'//sector, &
+ dt_ICE, mx, my, mi, xymi5)
+ call UNwrite(ID__nc_ice, 'TI'//sector, &
+ dt_ICE, mx, my, mi, xymi6)
+ call UNwrite(ID__nc_ice, 'WA'//sector, &
+ dt_ICE, mx, my, mi, xymi7)
+ ! + ************
+
+ enddo
+
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ xynsx1(i, j, k) = real(nssSNo(i, j, k))
+ xynsx2(i, j, k) = real(nisSNo(i, j, k))
+ xynsx3(i, j, k) = zn3IB(i, j, k) - zn0IB(i, j, k) &
+ - zn6IB(i, j, k)
+ zn6IB(i, j, k) = zn3IB(i, j, k) - zn0IB(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ ! ! Snapshot
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'nSSN', &
+ dt_ICE, mx, my, nsx, xynsx1)
+ call UNwrite(ID__nc_ice, 'nISN', &
+ dt_ICE, mx, my, nsx, xynsx2)
+ call UNwrite(ID__nc_ice, 'SWSN', &
+ dt_ICE, mx, my, nsx, SWaSNo)
+ call UNwrite(ID__nc_ice, 'ALSN', &
+ dt_ICE, mx, my, 1, albeSL)
+ call UNwrite(ID__nc_ice, 'MB', &
+ dt_ICE, mx, my, nsx, mbIB)
+ call UNwrite(ID__nc_ice, 'ZN', &
+ dt_ICE, mx, my, nsx, zn1IB)
+ call UNwrite(ID__nc_ice, 'ZN1', &
+ dt_ICE, mx, my, nsx, zn1IB)
+ call UNwrite(ID__nc_ice, 'ZN2', &
+ dt_ICE, mx, my, nsx, zn2IB)
+ call UNwrite(ID__nc_ice, 'ZN3', &
+ dt_ICE, mx, my, nsx, zn3IB)
+ call UNwrite(ID__nc_ice, 'ZN4', &
+ dt_ICE, mx, my, nsx, zn4IB)
+ call UNwrite(ID__nc_ice, 'ZN5', &
+ dt_ICE, mx, my, nsx, zn5IB)
+ call UNwrite(ID__nc_ice, 'ZN6', &
+ dt_ICE, mx, my, nsx, xynsx3)
+ call UNwrite(ID__nc_ice, 'ZN0', dt_ICE, mx, my, nsx, zn0IB)
+ call UNwrite(ID__nc_ice, 'MB0', dt_ICE, mx, my, nsx, mb0IB)
+ ! + ************
+
+ do k = 1, nsx
+
+ write(sector, '(i1)') k
+
+ do kk = 1, nsno
+ do j = 1, my
+ do i = 1, mx
+ xynsno1(i, j, kk) = agsSNo(i, j, k, kk)
+ xynsno2(i, j, kk) = dzsSNo(i, j, k, kk)
+ xynsno3(i, j, kk) = real(nhsSNo(i, j, k, kk))
+ xynsno4(i, j, kk) = g1sSNo(i, j, k, kk)
+ xynsno5(i, j, kk) = g2sSNo(i, j, k, kk)
+ xynsno6(i, j, kk) = rosSNo(i, j, k, kk)
+ xynsno7(i, j, kk) = tisSNo(i, j, k, kk) - TfSnow
+ xynsno8(i, j, kk) = wasSNo(i, j, k, kk)
+ enddo
+ enddo
+ enddo
+
+ ! Snapshot
+ ! + ************
+ call UNwrite(ID__nc_ice, 'agSN'//sector, dt_ICE, mx, my, nsno, xynsno1)
+ call UNwrite(ID__nc_ice, 'dzSN'//sector, dt_ICE, mx, my, nsno, xynsno2)
+ call UNwrite(ID__nc_ice, 'nhSN'//sector, dt_ICE, mx, my, nsno, xynsno3)
+ call UNwrite(ID__nc_ice, 'g1SN'//sector, dt_ICE, mx, my, nsno, xynsno4)
+ call UNwrite(ID__nc_ice, 'g2SN'//sector, dt_ICE, mx, my, nsno, xynsno5)
+ call UNwrite(ID__nc_ice, 'roSN'//sector, dt_ICE, mx, my, nsno, xynsno6)
+ call UNwrite(ID__nc_ice, 'tiSN'//sector, dt_ICE, mx, my, nsno, xynsno7)
+ call UNwrite(ID__nc_ice, 'waSN'//sector, dt_ICE, mx, my, nsno, xynsno8)
+ ! + ************
+
+ enddo
+
+ ! +--3.2.1.e Soil Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nsx
+ slqcIB(i, j, k) = 0
+ do kk = -nsol, 0
+ slqcIB(i, j, k) = Eta_TV(i, j, k, 1 - kk) * dzAvSV(kk) * ro_Wat + slqcIB(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call UNwrite(ID__nc_ice, 'SLQC', dt_ICE, mx, my, nvx, slqcIB)
+
+ do k = 1, nvx
+ write(sector, '(i1)') k
+ do kk = 1, llx
+ do j = 1, my
+ do i = 1, mx
+ xyllx1(i, j, kk) = TsolTV(i, j, k, kk) - TfSnow
+ xyllx2(i, j, kk) = Eta_TV(i, j, k, kk)
+ xyllx3(i, j, kk) = sltIB(i, j, k, kk)
+ xyllx4(i, j, kk) = slqIB(i, j, k, kk)
+ enddo
+ enddo
+ enddo
+
+ ! ! Daily mean + snapshot
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'SLTSN'//sector, &
+ dt_ICE, mx, my, llx, xyllx1)
+ call UNwrite(ID__nc_ice, 'SLQSN'//sector, &
+ dt_ICE, mx, my, llx, xyllx2)
+ call UNwrite(ID__nc_ice, 'SLT'//sector, &
+ dt_ICE, mx, my, llx, xyllx3)
+ call UNwrite(ID__nc_ice, 'SLQ'//sector, &
+ dt_ICE, mx, my, llx, xyllx4)
+ ! + ************
+
+ enddo
+
+ ! +--3.2.1.f Mass Balance Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ do j = 1, my
+ do i = 1, mx
+
+ WKxy1(i, j) = snowHY(i, j) * 1000.
+ WKxy2(i, j) = rainHY(i, j) * 1000.
+
+ enddo
+ enddo
+
+ ! ! Snapshot
+
+ ! + ************
+ ! call UNwrite (ID__nc_ice, 'SImass', dt_ICE, mx, my, nsx,SIm_IB)
+ ! call UNwrite (ID__nc_ice, 'SImadd', dt_ICE, mx, my, nsx,wei0IB)
+ ! call UNwrite (ID__nc_ice, 'S_mass', dt_ICE, mx, my, nsx,S_m_IB)
+ ! call UNwrite (ID__nc_ice, 'SI_hhh', dt_ICE, mx, my, nsx,SIh_IB)
+ ! call UNwrite (ID__nc_ice, 'S__hhh', dt_ICE, mx, my, nsx,S_h_IB)
+ ! call UNwrite (ID__nc_ice, 'SS_hhh', dt_ICE, mx, my, nsx,SSh_IB)
+ ! call UNwrite (ID__nc_ice, 'MBsubl', dt_ICE, mx, my, nsx,wes_IB)
+ ! call UNwrite (ID__nc_ice, 'MBmelt', dt_ICE, mx, my, nsx,wem_IB)
+ ! call UNwrite (ID__nc_ice, 'MBrefr', dt_ICE, mx, my, nsx,wer_IB)
+ ! call UNwrite (ID__nc_ice, 'MBruno', dt_ICE, mx, my, nsx,weu_IB)
+ ! call UNwrite (ID__nc_ice, 'MBsrfW', dt_ICE, mx, my, nsx,SWaSNo)
+ ! call UNwrite (ID__nc_ice, 'MBevap', dt_ICE, mx, my, nsx,wee_IB)
+ ! call UNwrite (ID__nc_ice, 'MBsnow', dt_ICE, mx, my, 1, WKxy1)
+ ! call UNwrite (ID__nc_ice, 'MBrain', dt_ICE, mx, my, 1, WKxy2)
+ ! call UNwrite (ID__nc_ice, 'MBroff', dt_ICE, mx, my, 1,runoTV)
+ ! + ************
+
+ ! + factim = (86400.0/real(OutdyIB)) / abs((itrdIB-iterun) *dt )
+ factim = 1.0
+ ! +... factim : Conversion Factor (x /elapsed time --> x /Days)
+
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nsx
+ xynsx1(i, j, k) = (CaWaTV(i, j, k) - wec0IB(i, j, k)) * factim
+ wec0IB(i, j, k) = CaWaTV(i, j, k) ! Canopy water content
+
+ xynsx2(i, j, k) = (weacIB(i, j, k) - weac0IB(i, j, k)) * factim
+ weac0IB(i, j, k) = weacIB(i, j, k) ! BS acc
+
+ xynsx3(i, j, k) = (weerIB(i, j, k) - weer0IB(i, j, k)) * factim
+ weer0IB(i, j, k) = weerIB(i, j, k) ! BS erosion
+
+ xynsx4(i, j, k) = (slqcIB(i, j, k) - wel0IB(i, j, k)) * factim
+ wel0IB(i, j, k) = slqcIB(i, j, k) ! Soil water content
+
+ ! Refreezing - Melting
+ xynsx5(i, j, k) = (wem_IB(i, j, k) - wem0IB(i, j, k)) * factim + (wer_IB(i, j, k) - wer0IB(i, j, k)) * factim
+ xynsx5(i, j, k) = (-1.) * xynsx6(i, j, k)
+
+ ! Refreezing
+ xynsx6(i, j, k) = (wer_IB(i, j, k) - wer0IB(i, j, k)) * factim
+ wer0IB(i, j, k) = wer_IB(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ CALL UNwrite(ID__nc_ice, 'MBcc', dt_ICE, mx, my, nsx, xynsx1)
+ CALL UNwrite(ID__nc_ice, 'MBac', dt_ICE, mx, my, nsx, xynsx2)
+ CALL UNwrite(ID__nc_ice, 'MBer', dt_ICE, mx, my, nsx, xynsx3)
+ CALL UNwrite(ID__nc_ice, 'MBsc', dt_ICE, mx, my, nsx, xynsx4)
+ CALL UNwrite(ID__nc_ice, 'MBmt', dt_ICE, mx, my, nsx, xynsx5)
+ CALL UNwrite(ID__nc_ice, 'MBr', dt_ICE, mx, my, nsx, xynsx6)
+
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nsx
+ xynsx1(i, j, k) = (wet_IB(i, j, k) - wet0IB(i, j, k)) * factim
+ wet0IB(i, j, k) = wet_IB(i, j, k) ! Total
+
+ xynsx2(i, j, k) = (wem_IB(i, j, k) - wem0IB(i, j, k)) * factim
+ xynsx2(i, j, k) = (-1.) * xynsx2(i, j, k)
+ wem0IB(i, j, k) = wem_IB(i, j, k) ! Only Melting
+
+ xynsx3(i, j, k) = (weu_IB(i, j, k) - weu0IB(i, j, k)) * factim
+ weu0IB(i, j, k) = weu_IB(i, j, k) ! Run-off
+
+ xynsx4(i, j, k) = (weo_IB(i, j, k, 2) - weo0IB(i, j, k, 2)) * factim
+ weo0IB(i, j, k, 2) = weo_IB(i, j, k, 2) ! Run-off from snow
+
+ xynsx5(i, j, k) = (wee_IB(i, j, k, 3) - wee0IB(i, j, k, 3)) * factim
+ wee0IB(i, j, k, 3) = wee_IB(i, j, k, 3) ! Subli from snow
+
+ xynsx6(i, j, k) = (wee_IB(i, j, k, 1) - wee0IB(i, j, k, 1)) * factim
+ wee0IB(i, j, k, 1) = wee_IB(i, j, k, 1) ! Evaporation
+
+ xynsx7(i, j, k) = (wee_IB(i, j, k, 2) - wee0IB(i, j, k, 2)) * factim
+ wee0IB(i, j, k, 2) = wee_IB(i, j, k, 2) ! Evapotranspiratuon
+
+ xynsx8(i, j, k) = (wee_IB(i, j, k, 4) - wee0IB(i, j, k, 4)) * factim
+ wee0IB(i, j, k, 4) = wee_IB(i, j, k, 4) ! Subli from soil
+
+ xynsx9(i, j, k) = (SWaSNo(i, j, k) - wesw0IB(i, j, k)) * factim
+ wesw0IB(i, j, k) = SWaSNo(i, j, k) ! Superficial Water
+ enddo
+
+ WKxy2(i, j) = 0.
+ do k = 1, nsx
+ WKxy2(i, j) = WKxy2(i, j) &
+ + SLsrfl(i, j, k) * snohSN(i, j, k) / 1000.
+ enddo
+
+ do kk = 1, ml
+ snf_IB(i, j, kk) = (snfHY(i, j, mz - kk + 1) - snf0IB(i, j, kk)) * factim
+ snf_IB(i, j, kk) = snf_IB(i, j, kk) * 1000.
+ snf0IB(i, j, kk) = snfHY(i, j, mz - kk + 1)
+ sbl_IB(i, j, kk) = (sblHY(i, j, mz - kk + 1) - sbl0IB(i, j, kk)) * factim
+ sbl_IB(i, j, kk) = sbl_IB(i, j, kk) * 1000.
+ sbl0IB(i, j, kk) = sblHY(i, j, mz - kk + 1)
+ ! cCA : check definition of qssbl; should be like LQS
+ qssbl_IB(i, j, kk) = (qssblHY(i, j, mz - kk + 1) - qssbl0IB(i, j, kk)) * factim
+ qssbl_IB(i, j, kk) = qssbl_IB(i, j, kk) * 1000. ! convertion mWE -> mmWE
+ qssbl0IB(i, j, kk) = qssblHY(i, j, mz - kk + 1)
+ dep_IB(i, j, kk) = (depHY(i, j, mz - kk + 1) - dep0IB(i, j, kk)) * factim
+ dep_IB(i, j, kk) = dep_IB(i, j, kk) * 1000.
+ dep0IB(i, j, kk) = depHY(i, j, mz - kk + 1)
+ rnf_IB(i, j, kk) = (rnfHY(i, j, mz - kk + 1) - rnf0IB(i, j, kk)) * factim
+ rnf_IB(i, j, kk) = rnf_IB(i, j, kk) * 1000.
+ rnf0IB(i, j, kk) = rnfHY(i, j, mz - kk + 1)
+ evp_IB(i, j, kk) = (evpHY(i, j, mz - kk + 1) - evp0IB(i, j, kk)) * factim
+ evp_IB(i, j, kk) = evp_IB(i, j, kk) * 1000.
+ evp0IB(i, j, kk) = evpHY(i, j, mz - kk + 1)
+ smt_IB(i, j, kk) = (smtHY(i, j, mz - kk + 1) - smt0IB(i, j, kk)) * factim
+ smt0ib(i, j, kk) = smtHY(i, j, mz - kk + 1)
+ enddo
+
+ WKxy2(i, j) = 0. ! snowfall does not taken into account
+ ! ! the snow in the SISVAT bluffer
+
+ WKxy1(i, j) = (snowHY(i, j) - wesf0IB(i, j) &
+ - WKxy2(i, j)) * factim
+ WKxy1(i, j) = max(0., WKxy1(i, j) * 1000.)
+ wesf0IB(i, j) = snowHY(i, j) - WKxy2(i, j) ! Snowfall
+
+ WKxy2(i, j) = (rainHY(i, j) - werr0IB(i, j)) * factim
+ WKxy2(i, j) = max(0., WKxy2(i, j) * 1000.)
+ werr0IB(i, j) = rainHY(i, j) ! Rain
+
+ WKxy3(i, j) = (rainCA(i, j) + snowCA(i, j) &
+ - wecp0IB(i, j)) * factim
+ WKxy3(i, j) = max(0., WKxy3(i, j) * 1000.)
+ wecp0IB(i, j) = rainCA(i, j) + snowCA(i, j) ! Convective precip.
+
+ WKxy4(i, j) = (runoTV(i, j) - wero0IB(i, j)) * factim
+ wero0IB(i, j) = runoTV(i, j) ! RunOFF
+
+ WKxy5(i, j) = (crysHY(i, j) - wecr0IB(i, j)) * factim
+ WKxy5(i, j) = max(0., WKxy5(i, j) * 1000.)
+ wecr0IB(i, j) = crysHY(i, j) ! Ice crystals
+
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nsx
+ xynsx0(i, j, k) = WKxy1(i, j) + WKxy2(i, j) - xynsx4(i, j, k) - xynsx5(i, j, k) ! smb = snf + rnf - sb
+ xynsx14(i, j, k) = WKxy2(i, j) + xynsx2(i, j, k) - xynsx9(i, j, k) ! rfz = r
+ enddo
+ ! if (isolSL(i, j)<=2) then ! ocean and sea-ice
+ ! xynsx0(i, j, 1) = NF_FILL_REAL ! SMB
+ ! xynsx5(i, j, 1) = NF_FILL_REAL ! Sublimation
+ ! xynsx2(i, j, 1) = NF_FILL_REAL ! Melting
+ ! xynsx4(i, j, 1) = NF_FILL_REAL ! Run-off
+ ! xynsx14(i, j, 1) = NF_FILL_REAL ! Refreezing
+ ! end if
+ enddo
+ enddo
+
+ ! ! Sum
+
+ ! + ************
+ call UNwrite(ID__nc_ice, 'smb', dt_ICE, mx, my, nsx, xynsx0)
+ call UNwrite(ID__nc_ice, 'snf', dt_ICE, mx, my, 1, WKxy1)
+ call UNwrite(ID__nc_ice, 'rnf', dt_ICE, mx, my, 1, WKxy2)
+ call UNwrite(ID__nc_ice, 'cry', dt_ICE, mx, my, 1, WKxy5)
+ CALL UNwrite(ID__nc_ice, 'sbl', dt_ICE, mx, my, nsx, xynsx5)
+ CALL UNwrite(ID__nc_ice, 'mlt', dt_ICE, mx, my, nsx, xynsx2)
+ CALL UNwrite(ID__nc_ice, 'rof', dt_ICE, mx, my, nsx, xynsx4)
+ CALL UNwrite(ID__nc_ice, 'rfz', dt_ICE, mx, my, nsx, xynsx14)
+ call UNwrite(ID__nc_ice, 'snf3D', dt_ICE, mx, my, ml, snf_IB)
+ call UNwrite(ID__nc_ice, 'sbl3D', dt_ICE, mx, my, ml, sbl_IB)
+ CALL UNwrite(ID__nc_ice, 'QSSBL', dt_ICE, mx, my, ml, qssbl_IB)
+ call UNwrite(ID__nc_ice, 'rnf3D', dt_ICE, mx, my, ml, rnf_IB)
+ CALL UNwrite(ID__nc_ice, 'dep3D', dt_ICE, mx, my, ml, dep_IB)
+ call UNwrite(ID__nc_ice, 'evp3D', dt_ICE, mx, my, ml, evp_IB)
+ call UNwrite(ID__nc_ice, 'smt3D', dt_ICE, mx, my, ml, smt_IB)
+
+ call UNwrite(ID__nc_ice, 'MBto', dt_ICE, mx, my, nsx, xynsx1)
+ call UNwrite(ID__nc_ice, 'MBic', dt_ICE, mx, my, 1, WKxy5)
+ call UNwrite(ID__nc_ice, 'MBsf', dt_ICE, mx, my, 1, WKxy1)
+ call UNwrite(ID__nc_ice, 'MBrr', dt_ICE, mx, my, 1, WKxy2)
+ CALL UNwrite(ID__nc_ice, 'MBrf', dt_ICE, mx, my, 1, WKxy2)
+ call UNwrite(ID__nc_ice, 'MBcp', dt_ICE, mx, my, 1, WKxy3)
+ call UNwrite(ID__nc_ice, 'MBru', dt_ICE, mx, my, 1, WKxy4)
+
+ CALL UNwrite(ID__nc_ice, 'MBsw', dt_ICE, mx, my, nsx, xynsx9)
+ CALL UNwrite(ID__nc_ice, 'MBm', dt_ICE, mx, my, nsx, xynsx2)
+
+ CALL UNwrite(ID__nc_ice, 'MBru2', dt_ICE, mx, my, nsx, xynsx3)
+ CALL UNwrite(ID__nc_ice, 'MBro2', dt_ICE, mx, my, nsx, xynsx4)
+ CALL UNwrite(ID__nc_ice, 'MBru3', dt_ICE, mx, my, nsx, xynsx4)
+
+ CALL UNwrite(ID__nc_ice, 'MBsn', dt_ICE, mx, my, nsx, xynsx5)
+ CALL UNwrite(ID__nc_ice, 'MBep', dt_ICE, mx, my, nsx, xynsx6)
+ CALL UNwrite(ID__nc_ice, 'MBet', dt_ICE, mx, my, nsx, xynsx7)
+ CALL UNwrite(ID__nc_ice, 'MBsl', dt_ICE, mx, my, nsx, xynsx8)
+ CALL UNwrite(ID__nc_ice, 'MBe', dt_ICE, mx, my, nsx, xynsx6 + xynsx7)
+ CALL UNwrite(ID__nc_ice, 'MBs', dt_ICE, mx, my, nsx, xynsx5 + xynsx8)
+
+ do j = 1, my
+ do i = 1, mx
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + smbhIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ smbhIB(i, j, k) = smbhIB(i, j, k) &
+ * xynsx1(i, j, 1) / tmp3
+ endif
+ enddo
+
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + swhIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ swhIB(i, j, k) = swhIB(i, j, k) * xynsx9(i, j, 1) / tmp3
+ endif
+ enddo
+
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + mehIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ mehIB(i, j, k) = mehIB(i, j, k) * xynsx2(i, j, 1) / tmp3
+ endif
+ enddo
+
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + 0.1 * mehIB(i, j, k) + 0.9 * ruhIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ ruhIB(i, j, k) = (0.1 * mehIB(i, j, k) + 0.9 * ruhIB(i, j, k)) * xynsx4(i, j, 1) / tmp3
+ else
+ if(abs(xynsx4(i, j, 1)) > 0.001) then
+ ruhIB(i, j, k) = xynsx4(i, j, 1) / real(mlhh)
+ else
+ ruhIB(i, j, k) = 0.
+ endif
+ endif
+ enddo
+
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + suhIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ suhIB(i, j, k) = suhIB(i, j, k) * xynsx5(i, j, 1) / tmp3
+ endif
+ enddo
+
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + snfhIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ snfhIB(i, j, k) = snfhIB(i, j, k) * WKxy1(i, j) / tmp3
+ endif
+ enddo
+
+ tmp3 = 0
+ do k = 1, mlhh
+ tmp3 = tmp3 + rfhIB(i, j, k)
+ enddo
+ do k = 1, mlhh
+ if(abs(tmp3) > 0.001) then
+ rfhIB(i, j, k) = rfhIB(i, j, k) &
+ * WKxy2(i, j) / tmp3
+ endif
+ prhIB(i, j, k) = rfhIB(i, j, k) + snfhIB(i, j, k)
+ enddo
+
+ enddo
+ enddo
+
+ ! For snow only
+ call UNwrite(ID__nc_ice, 'SMBh', dt_ICE, mx, my, mlhh, smbhIB)
+ call UNwrite(ID__nc_ice, 'SWh', dt_ICE, mx, my, mlhh, swhIB)
+ call UNwrite(ID__nc_ice, 'MEh', dt_ICE, mx, my, mlhh, mehIB)
+ call UNwrite(ID__nc_ice, 'PRh', dt_ICE, mx, my, mlhh, prhIB)
+ call UNwrite(ID__nc_ice, 'SUh', dt_ICE, mx, my, mlhh, suhIB)
+ call UNwrite(ID__nc_ice, 'RUh', dt_ICE, mx, my, mlhh, ruhIB)
+ call UNwrite(ID__nc_ice, 'SNFh', dt_ICE, mx, my, mlhh, snfhIB)
+ call UNwrite(ID__nc_ice, 'SFh', dt_ICE, mx, my, mlhh, snfhIB)
+ call UNwrite(ID__nc_ice, 'RFh', dt_ICE, mx, my, mlhh, rfhIB)
+
+ ! + Conservation on ice sheet: MBSF+MBRR-MBS-MBRU~MBTO-MBSW
+ ! + *******************************************************
+
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nsx
+ xynsx6(i, j, k) = (weo_IB(i, j, k, 1) - weo0IB(i, j, k, 1)) * factim
+ weo0IB(i, j, k, 1) = weo_IB(i, j, k, 1) ! Run-off
+ xynsx8(i, j, k) = (weo_IB(i, j, k, 3) - weo0IB(i, j, k, 3)) * factim
+ weo0IB(i, j, k, 3) = weo_IB(i, j, k, 3) ! Run-off
+ xynsx9(i, j, k) = (weo_IB(i, j, k, 4) - weo0IB(i, j, k, 4)) * factim
+ weo0IB(i, j, k, 4) = weo_IB(i, j, k, 4) ! Run-off
+ xynsx10(i, j, k) = (weo_IB(i, j, k, 5) - weo0IB(i, j, k, 5)) * factim
+ weo0IB(i, j, k, 5) = weo_IB(i, j, k, 5) ! Run-off
+ xynsx11(i, j, k) = (weo_IB(i, j, k, 6) - weo0IB(i, j, k, 6)) * factim
+ weo0IB(i, j, k, 6) = weo_IB(i, j, k, 6) ! Run-off
+ enddo
+ ! WKxy1(i, j) = 0
+ ! WKxy2(i, j) = 0
+ ! WKxy3(i, j) = 0
+ ! WKxy4(i, j) = 0
+ ! WKxy5(i, j) = 0
+ ! do k = 1, nsx
+ ! WKxy1(i, j) = WKxy1(i, j) + SLsrfl(i, j, k) * xynsx6(i, j, k)
+ ! WKxy2(i, j) = WKxy2(i, j) + SLsrfl(i, j, k) * xynsx7(i, j, k)
+ ! WKxy3(i, j) = WKxy3(i, j) + SLsrfl(i, j, k) * xynsx8(i, j, k)
+ ! WKxy4(i, j) = WKxy4(i, j) + SLsrfl(i, j, k) * xynsx9(i, j, k)
+ ! WKxy5(i, j) = WKxy5(i, j) + SLsrfl(i, j, k) * xynsx10(i, j, k)
+ ! end do
+ enddo
+ enddo
+
+ CALL UNwrite(ID__nc_ice, 'MBro1', dt_ICE, mx, my, mw, xynsx6)
+ CALL UNwrite(ID__nc_ice, 'MBro3', dt_ICE, mx, my, mw, xynsx8)
+ CALL UNwrite(ID__nc_ice, 'MBro4', dt_ICE, mx, my, mw, xynsx9)
+ CALL UNwrite(ID__nc_ice, 'MBro5', dt_ICE, mx, my, mw, xynsx10)
+ CALL UNwrite(ID__nc_ice, 'MBro6', dt_ICE, mx, my, mw, xynsx11)
+
+ ! +--3.2.2 Work Arrays Reset
+ ! + -----------------------
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy0(i, j) = 0.0
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ WKxy4(i, j) = 0.0
+ WKxy5(i, j) = 0.0
+ WKxy6(i, j) = 0.0
+ WKxy7(i, j) = 0.0
+ WKxy8(i, j) = 0.0
+ WKxy9(i, j) = 0.0
+ enddo
+ enddo
+
+ call NCSNC(ID__nc_ice, RCODE)
+
+ if(ID__nc_ice /= -1) then
+ ! + ************
+ call UNclose(ID__nc_ice)
+ ! + ************
+ ID__nc_ice = -1
+ endif
+
+ If(snapshot .and. ss == 1) then
+ ss = 0
+ fnamNC_tmp = fnamNC_ics
+ dt_ICE = dt_ICE - 1
+ goto 801
+ endif
+
+ OutdyIB0 = OutdyIB0 + 1
+ if(OutdyIB0 >= OutdyIB) OutdyIB0 = 0
+
+ itrdIB = iterun
+
+ ENDif !Daily
+
+ ! +--3.2.3 NetCDF File Closure
+ ! + -------------------------
+
+ if(ID__nc_ice /= -1) then
+ ! + ************
+ call UNclose(ID__nc_ice)
+ ! + ************
+ ID__nc_ice = -1
+ endif
+
+ deallocate(xyllx1)
+ deallocate(xyllx2)
+ deallocate(xyllx3)
+ deallocate(xyllx4)
+ deallocate(xymi1)
+ deallocate(xymi2)
+ deallocate(xymi3)
+ deallocate(xymi4)
+ deallocate(xymi5)
+ deallocate(xymi6)
+ deallocate(xymi7)
+ deallocate(xynsno1)
+ deallocate(xynsno2)
+ deallocate(xynsno3)
+ deallocate(xynsno4)
+ deallocate(xynsno5)
+ deallocate(xynsno6)
+ deallocate(xynsno7)
+ deallocate(xynsno8)
+ deallocate(xynsx0)
+ deallocate(xynsx1)
+ deallocate(xynsx2)
+ deallocate(xynsx3)
+ deallocate(xynsx4)
+ deallocate(xynsx5)
+ deallocate(xynsx6)
+ deallocate(xynsx7)
+ deallocate(xymlhh)
+ deallocate(xynsx8)
+ deallocate(xynsx9)
+ deallocate(xynsx10)
+ deallocate(xynsx11)
+ deallocate(xynsx12)
+ deallocate(xynsx13)
+ deallocate(xynsx14)
+
+ return
+end
diff --git a/MAR/code_mar/outsav.f90 b/MAR/code_mar/outsav.f90
new file mode 100644
index 0000000000000000000000000000000000000000..54d36296a036d8571fec3487db452b8b3114a167
--- /dev/null
+++ b/MAR/code_mar/outsav.f90
@@ -0,0 +1,319 @@
+#include "MAR_pp.def"
+subroutine outsav
+ ! +------------------------------------------------------------------------+
+ ! | MAR OUTPUT Mon 23-May-2011 MAR |
+ ! | subroutine outsav is used to save the main Model Variables |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_ub
+ use marsib
+ use mar_te
+ use mar_tu
+ use mar_ra
+ use mar_hy
+ use mar_ca
+ use mar_pb
+ use mar_sl
+ use mar_sv
+ use mar_bs
+ use mar_io
+#if(NH)
+ use mar_nh
+#endif
+#if(TC)
+ use mar_tc
+#endif
+#if(PO)
+ use mar_po
+#endif
+#if(iso)
+ use mariso, only: qvDY_iso, qvapSL_iso, &
+ dqv_CA_iso, dqw_CA_iso, dqi_CA_iso, &
+ drr_CA_iso, dss_CA_iso, dsn_CA_iso, &
+ rainCA_iso, snowCA_iso, &
+ qiHY_iso, qsHY_iso, qwHY_iso, &
+ qrHY_iso, rainHY_iso, rai0HY_iso, &
+ snowHY_iso, sno0HY_iso, sfa0HY_iso, crysHY_iso, &
+ SLuqs_iso, SLuqsl_iso
+#endif
+
+ implicit none
+
+ ! +-- Hydrostatic Dynamics
+ ! + ========================
+ open(unit=11, status='unknown', form='unformatted', file='MARdyn.DAT')
+ rewind 11
+ ! Time Parameters
+ write(11) itexpe, jdh_LB
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ ! Spatial Parameters
+ write(11) imez, jmez
+ write(11) GElat0, GElon0
+ ! Discretisation
+ write(11) sigma, ptopDY, dx, dy
+ ! Dynamics
+ write(11) uairDY
+ write(11) vairDY
+ write(11) pktaDY
+ write(11) pstDY
+ write(11) qvDY
+ write(11) sh
+ write(11) pstDY1
+ ! Lateral Boundary Conditions
+ write(11) iyr_LB, mma_LB, jda_LB, jhu_LB, jdh_LB
+ write(11) vaxgLB, vaxdLB, vayiLB, vaysLB
+ write(11) sst_LB
+ ! Upper Sponge Reference State
+ write(11) uairUB, vairUB, pktaUB
+ write(11) pstDYn
+ write(11) RAd_ir
+ write(11) IRsoil
+ write(11) virDY
+ write(11) tim1LB, v1xgLB, v1xdLB, v1yiLB, v1ysLB
+ write(11) tim2LB, v2xgLB, v2xdLB, v2yiLB, v2ysLB
+ write(11) sst1LB, sst2LB
+ write(11) ua1_UB, ua2_UB
+ write(11) va1_UB, va2_UB
+ write(11) pkt1UB, pkt2UB
+ ! +
+ if(my == 1) then
+ write(11) ugeoDY
+ write(11) vgeoDY
+ endif
+ ! +
+ close(unit=11)
+#if(iso)
+ ! write isotopic composition of dynamical variables
+ open(unit=11, status='unknown', form='unformatted', file='MARdyn_iso.DAT')
+ rewind 11
+ write(11) qvDY_iso
+ close(unit=11)
+#endif
+#if(NH)
+ ! +--Non-Hydrostatic Dynamics
+ ! + ========================
+ open(unit=11, status='unknown', form='unformatted', file='MARonh.DAT')
+ rewind 11
+ write(11) itexpe
+ ! Time Parameters
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ ! Dynamics
+ write(11) ua0_NH
+ write(11) va0_NH
+ write(11) wa0_NH
+ write(11) wairNH
+ write(11) pairNH
+ close(unit=11)
+#endif
+
+ ! +--Mass Flux convective Scheme
+ ! + ===========================
+ if(convec) then
+ open(unit=11, status='unknown', form='unformatted', file='MARcva.DAT')
+ rewind 11
+ write(11) itexpe
+ ! Time Parameters
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ write(11) adj_CA
+ write(11) int_CA
+ write(11) dpktCA
+ write(11) dqv_CA
+ write(11) dqw_CA
+ write(11) dqi_CA
+ write(11) drr_CA
+ write(11) dss_CA
+ write(11) dsn_CA
+ write(11) rainCA
+ write(11) snowCA
+ write(11) tau_CA
+ write(11) Kstep1
+ write(11) K_CbT1
+ write(11) K_CbB1
+ write(11) P_CH_0
+ write(11) PdCH_1
+ write(11) PdTa_1
+ write(11) PdQa_1
+ write(11) PdQw_1
+ write(11) PdQi_1
+ write(11) Pdrr_1
+ write(11) Pdss_1
+ write(11) PuMF_1
+ write(11) PdMF_1
+ write(11) Pfrr_1
+ write(11) Pfss_1
+ write(11) Pcape1
+ close(unit=11)
+#if(iso)
+ ! write isotopic composition of convective variables
+ open(unit=11, status='unknown', form='unformatted', file='MARcva_iso.DAT')
+ rewind 11
+ write(11) dqv_CA_iso
+ write(11) dqw_CA_iso
+ write(11) dqi_CA_iso
+ write(11) drr_CA_iso
+ write(11) dss_CA_iso
+ write(11) dsn_CA_iso
+ write(11) rainCA_iso
+ write(11) snowCA_iso
+ close(unit=11)
+#endif
+ endif
+
+ ! +--Microphysics
+ ! + ============
+ if(micphy) then
+ open(unit=11, status='unknown', form='unformatted', file='MARcld.DAT')
+ rewind 11
+ write(11) itexpe
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ write(11) turnHY
+ write(11) ccniHY
+ write(11) qiHY
+ write(11) qsHY
+#if(qg)
+ write(11) qgHY
+#endif
+ write(11) qwHY
+ write(11) qrHY
+ write(11) rainHY, rai0HY
+ write(11) snowHY, sno0HY, sfa0HY
+ write(11) crysHY
+ write(11) rainCA
+#if(BS)
+ write(11) uss_HY
+#endif
+ close(unit=11)
+#if(iso)
+ ! write isotopic composition of microphysics water
+ open(unit=11, status='unknown', form='unformatted', file='MARcld_iso.DAT')
+ rewind 11
+ write(11) qiHY_iso
+ write(11) qsHY_iso
+ write(11) qwHY_iso
+ write(11) qrHY_iso
+ write(11) rainHY_iso, rai0HY_iso
+ write(11) snowHY_iso, sno0HY_iso, sfa0HY_iso
+ write(11) crysHY_iso
+ ! rainCA_iso already in 'MARcva_iso.DAT'
+ ! write(11) rainCA_iso
+ close(unit=11)
+#endif
+ endif
+#if(TC)
+ ! +--Atmospheric Tracers
+ ! + ===================
+ open(unit=11, status='unknown', form='unformatted', file='MARtca.DAT')
+ rewind 11
+ write(11) itexpe
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ write(11) dt_ODE, dt2ODE, nt_ODE, jt_ODE
+ write(11) qxTC
+ write(11) qsTC
+ write(11) uqTC
+ close(unit=11)
+#endif
+#if(PO)
+ ! +--Polynya Model
+ ! + =============
+ if(polmod) then
+ open(unit=11, status='unknown', form='unformatted', file='MARpol.DAT')
+ rewind 11
+ write(11) itexpe
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ write(11) isolSL
+ write(11) iPO1, iPO2, jPO1, jPO2, iPO3, iPO4, jPO3, jPO4
+ write(11) hfraPO, vgriPO, uocnPO, vocnPO, swsaPO, focnPO
+ write(11) silfPO, hicePO, aicePO, uicePO, vicePO, dtPO
+ close(unit=11)
+ endif
+#endif
+ ! +--Soil Model
+ ! + ==========
+ open(unit=11, status='unknown', form='unformatted', file='MARsol.DAT')
+ rewind 11
+ write(11) itexpe
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ write(11) nSLsrf
+ write(11) SLsrfl
+ write(11) TairSL
+ write(11) tsrfSL
+ write(11) alb0SL, eps0SL
+ write(11) SaltSL
+ write(11) ro_SL0
+ write(11) ro_SL
+ write(11) d1_SL
+ write(11) t2_SL
+ write(11) w2_SL, wg_SL
+ write(11) roseSL
+ write(11) qvapSL
+ write(11) hsnoSL
+ write(11) hmelSL
+ write(11) SLuusl, SL_z0
+ write(11) SLutsl, SL_r0
+ write(11) pktaSL
+ write(11) sicsIB
+ write(11) sic1sI, sic2sI
+ write(11) albeSL
+ write(11) SLuus, SLuts
+ write(11) SLuqs, SLuqsl
+ write(11) duusSL
+ write(11) dutsSL
+ write(11) cdmSL, cdhSL
+ write(11) V_0aSL
+ write(11) dT0aSL
+#if(AM)
+ write(11) u_0aSL
+#endif
+#if(AT)
+ write(11) uT0aSL
+#endif
+#if(AS)
+ write(11) us0aSL
+#endif
+#if(VX)
+ write(11) WV__SL
+#endif
+ write(11) SLlmo, SLlmol
+#if(BV)
+ write(11) virSL
+#endif
+ close(unit=11)
+#if(iso)
+ ! write isotopic composition of surface air water
+ open(unit=11, status='unknown', form='unformatted', file='MARsol_iso.DAT')
+ rewind 11
+ write(11) qvapSL_iso
+ write(11) SLuqs_iso
+ write(11) SLuqsl_iso
+ close(unit=11)
+#endif
+ ! +--SVAT Model
+ ! + ==========
+ if(vegmod) then
+ ! + ***********
+ call svasav('writ')
+ ! + ***********
+ endif
+ ! +--Turbulence
+ ! + ==========
+ open(unit=11, status='unknown', form='unformatted', file='MARtur.DAT')
+ rewind 11
+ write(11) itexpe
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ ! TURBULENT KINETIC ENERGY (TKE) and DISSIPATION (e)
+ write(11) ect_TE
+ write(11) eps_TE
+ write(11) tranTE
+ ! TURBULENT DIFFUSION COEFFICIENT
+ write(11) TUkvm
+ write(11) TUkvh
+ close(unit=11)
+ return
+end
diff --git a/MAR/code_mar/pbltop.f90 b/MAR/code_mar/pbltop.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4bb89586833c3d9b52d471b2ea92aaf76db8b2e0
--- /dev/null
+++ b/MAR/code_mar/pbltop.f90
@@ -0,0 +1,180 @@
+subroutine PBLtop(TKE_1D, HHH_1D, h__PSL, h__SSL)
+ ! +---------------------------------------------------------------------------+
+ ! | 07-APR-2005 |
+ ! | PBLtop computes the height of the Primary Seeing Layer PSL |
+ ! | Secondary Seeing Layer SSL |
+ ! | |
+ ! | INPUT: TKE_1D: Turbulent Kinetic Energy [m2/s2] |
+ ! | HHH_1D: Height above the Surface [m] |
+ ! | |
+ ! | OUTPUT: h__PSL: Height of the Primary Seeing Layer [m] |
+ ! | h__SSL: Height of the Secondary Seeing Layer [m] |
+ ! | |
+ ! +---------------------------------------------------------------------------+
+
+ use mardim
+
+ implicit none
+
+ real TKE_1D(mz)
+ real HHH_1D(mz)
+ real h__PSL
+ real h__SSL
+
+ real TKEmin
+ real TKEtop
+
+ integer k, kmx, kzi
+
+ logical RESET
+ logical INTERP
+
+ DATA TKEmin/1.e-6/
+
+ INTERP = .false.
+
+ ! +--Height of the Primary Seeing Layer (PSL)
+ ! + ==========================================
+
+ ! +--Search the lowest TKE maximum
+ ! + -----------------------------
+
+ k = mz
+ TKEtop = 0.01 * TKE_1D(k)
+1001 continue
+ k = k - 1
+ if(k <= mzabso) go to 1000
+ if(TKE_1D(k) < TKE_1D(k + 1) .and. &
+ TKE_1D(k + 1) > TKEmin * 3.00) go to 1000
+ ! + 3.00 = 1/2 order of magnitude
+ ! + (in order to only detect a significant maximum)
+ go to 1001
+1000 continue
+ kmx = k + 1
+ TKEtop = 0.01 * TKE_1D(kmx)
+ TKEtop = max(TKEmin * 1.50, TKEtop)
+ ! + 1.50 = 1/4 order of magnitude
+
+ ! +--Search (from above) the lowest TKE minimum above the lowest TKE maximum
+ ! + ------ (This mimimum may be ) ----------
+ ! + (either a TRUE minimum => INTERP = .false.)
+ ! + ( or an arbitrary small value => INTERP = .true. )
+ ! + -----------------------------------------------------
+
+ ! +--Index of the layer containing the minimum
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ kzi = mzabso
+ do k = mzabso, kmx
+ if(TKE_1D(k) < TKEtop .OR. &
+ TKE_1D(k) < TKE_1D(k - 1) * 0.3) then
+ kzi = k
+ if(TKE_1D(k) < TKEtop) then
+ INTERP = .true.
+ else
+ INTERP = .false.
+ endif
+ endif
+ enddo
+
+ ! +--Height of the minimum
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ k = kzi
+ if(kzi <= mzabso + 1) then
+ h__PSL = HHH_1D(mz)
+ else
+ if(INTERP) then
+ h__PSL = HHH_1D(k + 1) &
+ + (HHH_1D(k) - HHH_1D(k + 1)) &
+ * (TKEtop - TKE_1D(k + 1)) &
+ / (TKE_1D(k) - TKE_1D(k + 1))
+ else
+ h__PSL = HHH_1D(k)
+ endif
+ endif
+
+ h__PSL = min(h__PSL, HHH_1D(1))
+ h__PSL = max(HHH_1D(mz), h__PSL)
+
+ ! +--Height of the Secondary Seeing Layer (SSL)
+ ! + ==========================================
+
+ RESET = .true.
+
+ ! +--Search the TKE minimum above the Primary Seeing Layer (PSL)
+ ! + (necessary if the TKE has decreased below the minimum value)
+ ! + ------------------------------------------------------------------
+
+ if(INTERP) then
+ k = kzi + 1
+1011 continue
+ k = k - 1
+ if(k <= mzabso) go to 1010
+ if(TKE_1D(k) < TKE_1D(k + 1)) go to 1011
+1010 continue
+ else
+ k = kzi
+ endif
+
+ ! +--Search the first TKE maximum above the Primary Seeing Layer (PSL)
+ ! + ------------------------------------------------------------------
+
+ kmx = kzi
+ k = k + 1
+1021 continue
+ k = k - 1
+ if(k <= mzabso) go to 1020
+ if(TKE_1D(k) > TKE_1D(k - 1) .and. &
+ TKE_1D(k) > TKE_1D(k + 1) .and. &
+ TKE_1D(k) > TKEmin * 3.0) then
+ ! + 3.0 = 1/2 order of magnitude
+ ! + (in order to only detect a significant maximum)
+
+ ! +--Define the TKE at the SSL top from the largest maximum in the SSL
+ ! + (thus examine the remaining upper part of the atmospheric column)
+ ! + -----------------------------------------------------------------
+
+ if(RESET) then
+ RESET = .false. ! indicates TKEtop is initialized
+ TKEtop = 0.00 !
+ endif
+ if(TKEtop < TKE_1D(k) * 0.01) then
+ TKEtop = TKE_1D(k) * 0.01
+ kmx = k
+ endif
+ endif
+ go to 1021
+1020 continue
+ TKEtop = max(TKEmin * 3.0, TKEtop)
+ ! + 3.0 = 1/2 order of magnitude
+
+ ! +--Search (from above) the SSL top above the SSL TKE maximum
+ ! + ------ (This may be ) ----------
+ ! + (either a TRUE minimum => INTERP = .false.)
+ ! + ( or an arbitrary small value => INTERP = .true. )
+ ! + -----------------------------------------------------
+
+ kzi = mzabso
+ do k = kmx, mzabso, -1
+ if(TKE_1D(k) > TKEtop) &
+ kzi = k
+ enddo
+
+ k = kzi - 1
+ if(kzi <= mzabso + 1) then
+ h__SSL = HHH_1D(mz)
+ else
+ if(INTERP) then
+ h__SSL = HHH_1D(k + 1) &
+ + (HHH_1D(k) - HHH_1D(k + 1)) &
+ * (TKEtop - TKE_1D(k + 1)) &
+ / (TKE_1D(k) - TKE_1D(k + 1))
+ else
+ h__SSL = HHH_1D(k)
+ endif
+ endif
+
+ h__SSL = min(h__SSL, HHH_1D(1))
+ h__SSL = max(h__PSL, h__SSL)
+
+ return
+end
diff --git a/MAR/code_mar/phy_sisvat.f90 b/MAR/code_mar/phy_sisvat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fd5ab2f6f90b3d52077760e78d42ccb0188c40b5
--- /dev/null
+++ b/MAR/code_mar/phy_sisvat.f90
@@ -0,0 +1,2405 @@
+#include "MAR_pp.def"
+subroutine PHY_SISVAT_MP(ihamr_SIS, nhamr_SIS)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_Driver 09-03-2021 MAR |
+ ! | subroutine PHY_SISVAT interfaces MAR with the |
+ ! | Soil/Ice Snow Vegetation Atmosphere Transfer Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: ihamr_SIS: Time Digital Filter Status |
+ ! | ^^^^^ nhamr_SIS: Time Digital Filter Set Up |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ VegMod: SISVAT is set up when .T. |
+ ! | SnoMod: Snow Pack is set up when .T. |
+ ! | reaLBC: Update Bound.Condit.when .T. |
+ ! | iterun: Run Iterations Counter |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ xxxxTV: SISVAT/MAR interfacing variables |
+ ! | |
+ ! | # CAUTION: #sa: Stand Alone Preprocessing Label must be removed |
+ ! | # ^^^^^^^ when SISVAT is coupled with MAR |
+ ! | |
+ ! | Preprocessing Option: SISVAT PHYSICS |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ |
+ ! | # #HY |
+ ! | # #SN: Snow Model |
+ ! | # #BS: Blowing Snow Parameterization |
+ ! | # #SI Sea-Ice Parameterization |
+ ! | # #GP LAI and GLF Variations not specified |
+ ! | # #OP SST is interactive |
+ ! | |
+ ! | # #DS: diffuse radiation differing from direct |
+ ! | (variable RADsod must still be included) |
+ ! | |
+ ! | Preprocessing Option: SISVAT PHYSICS: Col de Porte |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! | # #CP: SBL, Col de Porte |
+ ! | # #cp Solar Radiation, Col de Porte |
+ ! | # #AG: Snow Ageing, Col de Porte |
+ ! | |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # ANI.yyyymmdd.LAB.nc | #NC: OUTPUT on NetCDF File (Stand Alone EXP.) |
+ ! | | |
+ ! | # SISVAT_iii_jjj_n | #E0: OUTPUT on ASCII File (SISVAT Variables) |
+ ! | # |(#E0 MUST BE PREPROCESSED BEFORE #e1 & #e2 !) |
+ ! | # SISVAT_iii_jjj_n | #e1: OUTPUT/Verification: Energy Conservation |
+ ! | # SISVAT_iii_jjj_n | #e2: OUTPUT/Verification: Energy Consrv.2e pt.|
+ ! | | (no premature stop) |
+ ! | | |
+ ! | # SISVAT_iii_jjj_n | #m0: OUTPUT/Verification: H2O Conservation |
+ ! | # SISVAT_iii_jjj_n | #m1: OUTPUT/Verification: * Mass Conservation |
+ ! | # SISVAT_iii_jjj_n | #m2: OUTPUT/Verification: SeaIce Conservation |
+ ! | | |
+ ! | # SISVAT_zSn.vz | #vz: OUTPUT/Verification: Snow Layers Agrega. |
+ ! | | unit 41, subroutine SISVAT_zSn **ONLY** |
+ ! | # SISVAT_qSo.vw | #vw: OUTPUT/Verif+Detail: H2O Conservation |
+ ! | | unit 42, subroutine SISVAT_qSo **ONLY** |
+ ! | # SISVAT_qSn.vm | #vm: OUTPUT/Verification: Energy/Water Budget |
+ ! | | unit 43, subroutine SISVAT_qSn **ONLY** |
+ ! | # SISVAT_qSn.vu | #vu: OUTPUT/Verification: Slush Parameteriz. |
+ ! | | unit 44, subroutine SISVAT_qSn **ONLY** |
+ ! | # SISVAT_wEq.ve | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. |
+ ! | | unit 45, subroutine SISVAT_wEq **ONLY** |
+ ! | # SnOptP____.va | #va: OUTPUT/Verification: Albedo Parameteriz. |
+ ! | | unit 46, subroutine SnOptP **ONLY** |
+ ! | # SISVAT_GSn.vp | #vp: OUTPUT/Verification: Snow Properties |
+ ! | | unit 47, subroutines SISVAT_zSn, _GSn |
+ ! | # PHY_SISVAT.v0 | #v0: OUTPUT/Verification: DUMP |
+ ! | | unit 50, subroutine PHY_SISVAT **ONLY** |
+ ! | | |
+ ! | # stdout | #s0: OUTPUT of Snow Buffer Layer |
+ ! | | unit 6, subroutine SISVAT **ONLY** |
+ ! | # stdout | #wx: OUTPUT/Verification: specified i,j,k,n |
+ ! | # stdout | #wz: OUTPUT of Roughness Length (Blown Snow) |
+ ! | | unit 6, subroutines SISVAT, PHY_SISVAT |
+ ! | | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_ra
+ use mar_lb
+ use mar_dy
+ use mar_hy
+ use mar_tu
+ use mar_sv
+ use mardSV
+ use mar0SV
+ use mar_sl
+ use mar_TV
+ use mar_bs
+ use marssn
+ use mar_ib
+ use marsib
+ use mar_wk
+ use marmagic
+#if(BW)
+ use mar_te
+#endif
+#if(TC)
+ use mar_tc
+#endif
+#if(AO)
+ use mar_AO
+#endif
+#if(PO)
+ use mar_po
+#endif
+ ! +--INTERFACE Variables
+ ! + ===================
+ use marxsv
+ use marysv
+#if(iso)
+ use mariso, only: wiso, niso, qsrfHY_iso, SLuqsl_iso, uqs_SV_iso, &
+ SLuqs_iso, qvapSL_iso, evapTV_iso, Rdefault
+#endif
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ integer ihamr_SIS, nhamr_SIS ! Hamming Filter Counters
+ integer newglfSIS !
+ integer newsicSI !
+
+ real rtime
+ integer ntime
+ common / c_time / ntime
+
+ integer mw0
+ parameter(mw0=3)
+
+ ! +--Level of negligible blown Snow Particles Concentration
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer kB
+ common / SISVAT_MAR__BS / kB
+
+ ! +--10-m Level
+ ! + ~~~~~~~~~~
+ integer kSBL
+ common / PHY_SISVAT_SBLi / kSBL
+ real rSBL10, VV__10(mx, my), ERprev(mx, my, mw)
+ common / PHY_SISVAT_SBLr / rSBL10, ERprev
+
+ ! +--V, dT(a-s) Time Moving Averages
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ real V__mem(klonv, ntaver) ! ntaver defined in MAR_SL.inc
+ real VVmmem(klonv) !
+ common / SVeSBLmem / V__mem, VVmmem !
+ real T__mem(klonv, ntaver) !
+ real dTmmem(klonv) !
+ common / STeSBLmem / T__mem, dTmmem !
+
+ !$OMP threadprivate(/SVeSBLmem/,/STeSBLmem/)
+
+ ! +--u*, u*T*, u*s* Time Moving Averages
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(AM)
+ ! ntaver defined in mar_sl
+ real u__mem(klonv, ntaver)
+ common / S_eSBLmem / u__mem
+#endif
+#if(AT)
+ real uT_mem(klonv, ntaver), uT_mem
+#endif
+#if(AS)
+ real us_mem(klonv, ntaver), us_mem
+#endif
+
+ ! +--OUTPUT for Stand Alone NetCDF File
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(NC)
+ ! SOsoKL : Absorbed Solar Radiation
+ real SOsoKL(klonv)
+ ! IRsoKL : Absorbed IR Radiation
+ real IRsoKL(klonv)
+ ! HSsoKL : Absorbed Sensible Heat Flux
+ real HSsoKL(klonv)
+ ! HLsoKL : Absorbed Latent Heat Flux
+ real HLsoKL(klonv)
+ ! HLs_KL : Evaporation
+ real HLs_KL(klonv)
+ ! HLv_KL : Transpiration
+ real HLv_KL(klonv)
+ common / DumpNC / SOsoKL, IRsoKL, HSsoKL, HLsoKL, HLs_KL, HLv_KL
+ ! SOsoNC : Absorbed Solar Radiation
+ real SOsoNC(mx, my, nvx)
+ ! IRsoNC : Absorbed IR Radiation
+ real IRsoNC(mx, my, nvx)
+ ! HSsoNC : Absorbed Sensible Heat Flux
+ real HSsoNC(mx, my, nvx)
+ ! HLsoNC : Absorbed Latent Heat Flux
+ real HLsoNC(mx, my, nvx)
+ ! HLs_NC : Evaporation
+ real HLs_NC(mx, my, nvx)
+ ! HLv_NC : Transpiration
+ real HLv_NC(mx, my, nvx)
+ ! eta_NC : Soil Humidity
+ real eta_NC(mx, my, nvx)
+ common / writNC / SOsoNC, IRsoNC, HSsoNC, HLsoNC, HLs_NC, HLv_NC, eta_NC
+#endif
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+ common / SISVAT_EV / iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+#endif
+
+ ! +--Internal Variables
+ ! + ===================
+ integer i, j, k, m
+ logical StandA, snow_filter
+ logical glfFIX
+ ! ijnmax, nvcmax : Control Indices Distribution
+ integer ijnmax, nvcmax
+ common / SISVAT_MAR_Loc / ijnmax, nvcmax
+ ! k2i : Distributed i Index
+ integer k2i(klonv)
+ ! k2j : Distributed j Index
+ integer k2j(klonv)
+ ! k2n : Distributed mosaic Index
+ integer k2n(klonv)
+#if(VR)
+ ! ij0ver : Verification of Vectorization
+ integer ij0ver(mx, my, mw)
+ ! ij_ver : Verification of Vectorization
+ integer ij_ver(mx, my, mw)
+ ! ij2, ijdver : Verification of Vectorization
+ integer ij2, ijdver(mx, my, mw)
+#endif
+ character * 1 cha, chb
+ integer iwr, ipt, l, nvcmax2, ijnmax2, itPhys
+ integer ikl, isl, isn
+ integer ijn, ij, nnn
+ integer nvc, nkl, n, nt
+
+ ! slopx, slopy : Surf.Slope, x, y
+ real slopx, slopy
+ ! czemin : Minimum accepted cos(Solar zenith.Dist.)
+ real czemin
+ ! Upw_IR : Upward IR Flux
+ real Upw_IR(mx, my)
+ ! IR_aux : Upward IR Flux (dummy)
+ real IR_aux
+ ! uqstar : u*q*
+ real uqstar
+ ! rhAir : Air Densitity
+ real rhAir
+ ! Ua_min : Minimum Air Velocity
+ real Ua_min
+ ! rr__DR : Desagregated Rain
+ real rr__DR(mx, my, mw)
+ ! hfra : Frazil Thickness
+ real hfra(mx, my, mw)
+ ! Rnof : RunOFF Intensity
+ real Rnof(mx, my, mw)
+ ! Ruof : RunOFF Intensity
+ real Ruof(mx, my, mw, 6)
+ ! EvSu : RunOFF Intensity
+ real EvSu(mx, my, mw, 4)
+ ! d_snow, SnowOK : Snow Precip.: Total
+ real d_snow, SnowOK
+ ! dbsnow : Snow Precip.: from Drift
+ real dbsnow
+#if(SZ)
+ ! dsastr : z0(Sastrugi): Variation
+ real dsastr(mx, my)
+#endif
+ real WVaLim(mx, my)
+ ! FixSST, VarSST : SST forcing switch
+ real FixSST, VarSST
+ ! SSTnud : SST Nudging Rate
+ real SSTnud
+ common / SISVAT_MAR_ocn / FixSST, VarSST, SSTnud
+
+ real ifra_t
+ !XF
+ ! SrfSIC, SIc0OK : Oceanic Fraction: previous
+ real SrfSIC, SIc0OK
+ ! FraOcn, SIceOK : Oceanic Fraction
+ real FraOcn, SIceOK
+ ! TocnSI : Ocn Temp.=> S-Ice Covered
+ real TocnSI
+ ! OcnMin : Oceanic Fraction: Minimum
+ real OcnMin
+ ! dzSIce : Sea-Ice Layers Thickness
+ real dzSIce(4)
+ ! SIcMIN : Sea-Ice Layer Min Thickness
+ real SIcMIN
+ ! SIc_OK : Sea-Ice Switch
+ real SIc_OK(2)
+ ! c1_zuo, c2_zuo, c3_zuo : Run Off Parameters
+ real c1_zuo, c2_zuo, c3_zuo
+ ! SnowWE : Snow Water Equivalent[m w.e.]
+ real SnowWE
+ ! rosNEW : Added Snow Density [kg/m3]
+ real rosNEW
+ ! S_Eros, SnEros : Snow Erosion (status) = (1,0)
+ real S_Eros, SnEros
+#if(BW)
+ integer noUNIT
+ real BlowST, SnowSB
+#endif
+#if(WR)
+ ! ifrVER : Verification Variable: Total Fraction must be 100%
+ integer ifrVER(mx, my)
+#endif
+ real tairDY_2D(mx, my), qvDY_2D(mx, my)
+ real uu, vv, ww
+#if(AO)
+ !coupling ck AO
+ real zntot
+#endif
+
+ ! +--DATA
+ ! + ====
+ data StandA/.true./
+ data glfFIX/.false./
+ data cha/'-'/
+ data chb/':'/
+
+ data czemin/1.e-3/
+
+ data TocnSI/270.70/ ! Ocn Temp.=> S-Ice Covered
+#if(AO)
+ !AO_CK 20/02/2020 same as in NEMO
+ data OcnMin/0.01/
+#endif
+ data OcnMin/0.05/ ! Oceanic Fraction: Minimum
+ data dzSIce/0.5, 0.05, 0.001, 0.0/ ! Sea-Ice Layers Thickness
+ data SIcMIN/0.1/ ! Sea-Ice Layer Min Thickness
+ data SIc_OK/1.0, 0.00/ ! Sea-Ice Switch
+ ! +
+ ! data c1_zuo/12.960e+4/,c2_zuo/2.160e+6/,c3_zuo/1.400e+2/ ! Zuoriginal
+ ! data c1_zuo/ 2.796e+4/,c2_zuo/2.160e+6/,c3_zuo/1.400e+2/ ! ETH Tuning
+ ! data c1_zuo/ 86400/,c2_zuo/ 777600/,c3_zuo/1.400e+2/ ! 1-10 days
+ ! from 12h (c1_zuo) to 18h (c1_zuo+c2_zuo).
+ data c1_zuo/10800/, c2_zuo/54000/, c3_zuo/1.400e+2/ ! 1 day max
+
+ ! +... Run Off Parameters
+ ! + 86400*1.5 day ...*25 days (Modif. ETH Camp: 86400*0.3day)
+ ! + (Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
+
+ ! +--SISVAT Time Variable
+ ! + ================================
+ dt__SV = dt
+
+ ! + ++++++++++++++++ INITIALISATION: BEGIN +++
+ if(.not. INI_SV) then
+ ! + ++++++++++++++++
+
+ ! +--OUTPUT point (i,j,n) coordinates
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ iwr_SV = 1
+ jwr_SV = 1
+ nwr_SV = 1
+
+ ! +--Level of negligible blown Snow Particles Concentration ( ~ 100magl)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ kB = mz
+11 continue
+#if(AE)
+ if(zsigma(kB) > 100. .OR. kB <= 1) go to 10
+ kB = kB - 1
+ go to 11
+#endif
+10 continue
+#if(AE)
+ write(6, 1000) kB
+#endif
+1000 format(/, ' BS : Level of negligible ' &
+ , 'blown Snow Particles Concentration is', i4 &
+ , ' (i.e., ~ 100. magl)',/)
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! Snow Erosion Statistics: Grid Point Coordinate
+ iSV_v1 = imez
+ ! Id.
+ jSV_v1 = jmez
+ ! Id.
+ nSV_v1 = 1
+ ! Snow Erosion Statistics: OUTPUT SWITCH (if > 0)
+ ! .LE. 1 Blowing Snow
+ ! .LE. 2 Blowing Snow (FULL)
+ ! .EQ. 3 Snow Agregation
+ lSV_v1 = 1
+#endif
+
+ ! +--SISVAT Time Independant Variables
+ ! + =================================
+
+ StandA = .false.
+ if(VSISVAT .and. StandA) then
+ write(6, 600)
+600 format(/, '### MAR_SISVAT CRASH,', &
+ ' STAND ALONE LABEL #sa is ON ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 15x, 'EMERGENCY STOP')
+ stop
+ endif
+
+ if(mw /= nvx) then
+ write(6, 601) mw, nvx
+601 format(/, '### MAR_SISVAT CRASH, mw =', i6, &
+ ' .NE. nvx =', i6, ' ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 15x, 'EMERGENCY STOP')
+ stop
+ endif
+
+ if(mw /= nsx) then
+ write(6, 602) mw, nsx
+602 format(/, '### MAR_SISVAT CRASH, mw =', i6, &
+ ' .NE. nvx =', i6, ' ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 15x, 'EMERGENCY STOP')
+ stop
+ endif
+
+ if(nsol + 1 /= llx) then
+ write(6, 603) nsol + 1, llx
+603 format(/, '### MAR_SISVAT CRASH, ns =', i6, &
+ ' .NE. nvx =', i6, ' ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 15x, 'EMERGENCY STOP')
+ stop
+ endif
+
+ if(nb_wri > mz) then
+ write(6, 604) nb_wri, mz
+604 format(/, '### MAR_SISVAT CRASH, nb_wri =', i6, &
+ ' .GT. mz =', i3, ' ', 2x, ' ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 23x, 'EMERGENCY STOP')
+ ! stop
+ endif
+
+ if(nb_wri > mw * iptx) then
+ write(6, 605) nb_wri, mw, iptx
+605 format(/, '### MAR_SISVAT CRASH, nb_wri =', i6, &
+ ' .GT. mw *iptx=', i3, '*', i2, ' ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 23x, 'EMERGENCY STOP')
+ ! stop
+ endif
+
+ if(nb_wri > nsx * iptx) then
+ write(6, 606) nb_wri, nsx, iptx
+606 format(/, '### MAR_SISVAT CRASH, nb_wri =', i6, &
+ ' .GT. nsx*iptx=', i3, '*', i2, ' ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 23x, 'EMERGENCY STOP')
+ stop
+ endif
+
+#if(BS)
+ if(klonv /= 256) then
+ write(6, 608) klonv
+608 format(/, '#BS MAR_SISVAT CRASH, klonv =', i6, '.ne.256 ###', &
+ /, ' ?!&~@|@[#@#]=!!!', 15x, 'EMERGENCY STOP')
+ stop
+ endif
+#endif
+
+ ! + ****************
+ call SISVAT_ini
+ ! + ****************
+
+ ! +--Grids Correspondance
+ ! + --------------------
+
+ do isl = -nsol, 0
+ deptTV(1 - isl) = dz_dSV(isl)
+ enddo
+
+ ntime = 0
+
+ ijnmax = mx2 * my2 * nvx
+ if(mod(ijnmax, klonv) == 0) then
+ nvcmax = ijnmax / klonv
+ else
+ nvcmax = ijnmax / klonv + 1
+ endif
+ ! +
+ ! +
+ ! +--Surface Fall Line Slope
+ ! + -----------------------
+ ! +
+ if(SnoMod) then
+ if(mx == 1 .and. my == 1) then
+ ! Normalized Decay of the
+ ! Surficial Water Content
+ !(Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
+ SWfSNo(1, 1) = &
+ exp(-dt__SV &
+ / (c1_zuo &
+ + c2_zuo * exp(-c3_zuo * slopTV(1, 1))))
+ else
+ do j = jp11, my1
+ do i = ip11, mx1
+ slopx = (sh(ip1(i), j) - sh(im1(i), j)) * dxinv3(i, j)
+ slopy = (sh(i, jp1(j)) - sh(i, jm1(j))) * dyinv3(i, j)
+ slopTV(i, j) = sqrt(slopx * slopx + slopy * slopy)
+ ! SWfSNo
+ ! Normalized Decay of the
+ ! Surficial Water Content
+ ! (Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
+ SWfSNo(i, j) = &
+ exp(-dt__SV &
+ / (c1_zuo &
+ + c2_zuo * exp(-c3_zuo * slopTV(i, j))))
+ slopGE(i, j) = cos(atan(slopTV(i, j)))
+ enddo
+ enddo
+ endif
+ endif
+
+ ! +--Initialization of Surface Types
+ ! + ===============================
+ if(itexpe == 0) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(maskSL(i, j) == 1) then
+ nSLsrf(i, j) = 1 ! Ocean Grid Pt
+ SLsrfl(i, j, 1) = 1.
+ if(mw > 1) then
+ do n = min(2, mw), nvx
+ SLsrfl(i, j, n) = 0.
+ enddo
+ endif
+ else
+ nSLsrf(i, j) = nvx ! Land Grid Pt
+ do n = 1, nvx
+ SLsrfl(i, j, n) = ifraTV(i, j, n)
+ SLsrfl(i, j, n) = SLsrfl(i, j, n) * 0.01
+ enddo
+ endif
+
+ ! +--Initialization of z0(Sastrugi)
+ ! + ==============================
+
+ ! Influence of the Angle(Wind,Sastrugi) (Andreas, 1995, CCREL report 95-16)
+ ! -------------------------------------------------------------------------
+
+#if(ZA)
+ ua_0BS(i, j) = uairDY(i, j, mz)
+ va_0BS(i, j) = vairDY(i, j, mz)
+#endif
+
+ ! Sastrugi Height
+ ! ---------------
+
+ do n = 1, mw
+#if(SZ)
+ Z0SaBS(i, j, n) = 0.
+#endif
+ do nt = 1, ntavSL
+ SLn_z0(i, j, n, nt) = 0.5e-6
+ SLn_b0(i, j, n, nt) = 0.5e-6
+ SLn_r0(i, j, n, nt) = 0.5e-6
+ enddo
+ enddo
+ enddo
+ enddo
+
+ endif
+
+#if(ZA)
+ ! Influence of the Angle(Wind,Sastrugi) (Andreas, 1995, CCREL report 95-16)
+ ! -------------------------------------------------------------------------
+ FracBS = exp(-dt__SV / 43200.)
+#endif
+
+#if(OR)
+ ! +--Initialization of z0(Orography Roughness)
+ ! + =========================================
+ do k = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ SL_z0(i, j, k) = min(SL_z0(i, j, k), zsigma(mz) / 3.)
+ SLzoro(i, j, k) = min(SLzoro(i, j, k), zsigma(mz) / 3.)
+ enddo
+ enddo
+ enddo
+#endif
+
+ ! +--Ocean Status
+ ! + ============
+ VarSST = 0.
+#if(OP)
+ VarSST = 1.
+#endif
+ FixSST = 1.-VarSST
+ SSTnud = exp(-dt__SV / 2.592e6) ! SST Nudging:
+ ! +... ! e-folding time: 30 Days
+ ! +
+ if(itexpe == 0) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(maskSL(i, j) > 0 .and. ifraTV(i, j, 1) < 100) then
+ write(6, 6000) i, j,(ifraTV(i, j, n), n=1, nvx)
+6000 format(' WARNING on Grid Point', 2i4, ' Mosaic = (', 3i4, &
+ '): ISLANDS must(will) be excluded')
+ do n = 1, nvx
+ ifraTV(i, j, n) = 0
+ ivegTV(i, j, n) = 0
+ enddo
+ ifraTV(i, j, 1) = 100
+ endif
+ enddo
+ enddo
+
+ ! +--Prescription from SST
+ ! + ---------------------
+ Tfr_LB = TocnSI
+#if(RE)
+ Tfr_LB = 271.35 + epsi
+#endif
+ do j = jp11, my1
+ do i = ip11, mx1
+ FraOcn = (TsolTV(i, j, 1, 1) - Tfr_LB) / TSIdSV! Open Ocean
+ FraOcn = 1.-sicsIB(i, j) ! Prescribed
+ FraOcn = min(unun, FraOcn) ! Fract.
+ FraOcn = max(OcnMin, FraOcn) !
+ ! New Ocean
+ SLsrfl(i, j, 1) = (1 - maskSL(i, j)) * SLsrfl(i, j, 1) &
+ + maskSL(i, j) * FraOcn !
+ SrfSIC = SLsrfl(i, j, 2) ! Old Sea Ice
+ SIc0OK = max(zero, sign(unun, SrfSIC - epsi)) !
+ ! New Sea Ice
+ SLsrfl(i, j, 2) = (1 - maskSL(i, j)) * SLsrfl(i, j, 2) &
+ + maskSL(i, j) * (1.-FraOcn) !
+ SIceOK = max(zero, sign(unun, SLsrfl(i, j, 2) &
+ - epsi)) !
+ ifra_t = ifraTV(i, j, 1) + ifraTV(i, j, 2) ! OCN Fract.
+ ifraTV(i, j, 1) = SLsrfl(i, j, 1) * 100. !
+ ifraTV(i, j, 1) = min(ifraTV(i, j, 1), ifra_t) !
+ ifraTV(i, j, 2) = ifra_t - ifraTV(i, j, 1) !
+
+ ! +--Sea-Ice Vertical Discretization
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ nssSNo(i, j, 2) = &
+ nssSNo(i, j, 2) * (1 - maskSL(i, j)) &
+ + (nssSNo(i, j, 2) * SIc0OK &
+ + 3 * (1.-SIc0OK) * SIceOK) * maskSL(i, j)
+
+ nisSNo(i, j, 2) = &
+ nisSNo(i, j, 2) * (1 - maskSL(i, j)) &
+ + (nisSNo(i, j, 2) * SIc0OK &
+ + 3 * (1.-SIc0OK) * SIceOK) * maskSL(i, j)
+ issSNo(i, j, 2) = nisSNo(i, j, 2)
+
+ do l = 1, nsno
+ dzsSNo(i, j, 2, l) = &
+ dzsSNo(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (dzsSNo(i, j, 2, l) * SIc0OK &
+ + dzSIce(min(4, l)) * (1.-SIc0OK) * SIceOK) * maskSL(i, j)
+
+ tisSNo(i, j, 2, l) = &
+ tisSNo(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (tisSNo(i, j, 2, l) * SIc0OK &
+ + TsolTV(i, j, 1, 1) * (1.-SIc0OK)) * maskSL(i, j)
+
+ rosSNo(i, j, 2, l) = &
+ rosSNo(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (rosSNo(i, j, 2, l) * SIc0OK &
+ + ro_Ice * (1.-SIc0OK) * SIceOK) * maskSL(i, j)
+
+ g1sSNo(i, j, 2, l) = &
+ g1sSNo(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (g1sSNo(i, j, 2, l) * SIc0OK &
+ + G1_dSV * (1.-SIc0OK) * SIceOK) * maskSL(i, j)
+
+ g2sSNo(i, j, 2, l) = &
+ g2sSNo(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (g2sSNo(i, j, 2, l) * SIc0OK &
+ + 30.*(1.-SIc0OK) * SIceOK) * maskSL(i, j)
+
+ nhsSNo(i, j, 2, l) = &
+ nhsSNo(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + istdSV(2) * maskSL(i, j)
+ enddo
+ do l = 1, llx
+ TsolTV(i, j, 2, l) = &
+ TsolTV(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (TsolTV(i, j, 2, l) * SIc0OK &
+ + TsolTV(i, j, 1, l) * (1.-SIc0OK)) * maskSL(i, j)
+
+ eta_TV(i, j, 2, l) = &
+ eta_TV(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + eta_TV(i, j, 2, l) * SIc0OK * maskSL(i, j)
+ ! +... No Pore in Ice => No Water
+ enddo
+
+#if(WI)
+ write(6, 6001) jdarGE, labmGE(mmarGE), iyrrGE &
+ , jhurGE, minuGE, jsecGE, TsolTV(i, j, 1, 1) &
+ , FraOcn, ifraTV(i, j, 1), TsolTV(i, j, 2, 1) &
+ , nisSNo(i, j, 2), nssSNo(i, j, 2)
+6001 format(/, 98('_'), &
+ /, i3, '-', a3, '-', i4, 3(':', i2), &
+ 2x, 'T OCN = ', f7.3, 4x, '% OCN = ', f7.3, '(', i3, ')', &
+ 2x, 'T ICE = ', f7.3, &
+ /, 42x, 'NbIce = ', i3, 11x, 'NbSno = ', i3)
+#endif
+
+ enddo
+ enddo
+ endif
+
+ ! +--Soil Upward IR Flux
+ ! + ===================
+
+ if(itexpe == 0) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ ! Upward IR Flux
+ IR_aux = -eps0SL(i, j) * stefan * TairSL(i, j)**4
+ do n = 1, nvx
+ IRsoil(i, j, n) = IR_aux
+ enddo
+ ! +--Water Vapor Flux Limitor
+ ! + ========================
+#if(VX)
+ do n = 1, nLimit
+ WV__SL(i, j, n) = 1.
+ enddo
+#endif
+ enddo
+ enddo
+
+ ! +--SBL Characteristics
+ ! + ====================
+ do nt = 1, ntaver
+ do j = 1, my
+ do i = 1, mx
+ V_0aSL(i, j, nt) = ssvSL(i, j, mz)
+ do n = 1, nvx
+ dT0aSL(i, j, n, nt) = tairDY(i, j, mz) - tsrfSL(i, j, n)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! +--OUTPUT Files Definition
+ ! + =======================
+#if(v0)
+ open(unit=50, status='unknown', file='PHY_SISVAT.v0')
+ rewind 50
+#endif
+ if(mmy <= 1 .and. mw > mw0) then
+ open(unit=51, status='unknown', file='Dsagrr.OUT')
+ rewind 51
+ write(51, 5100)
+5100 format(/, ' Simple Disagregation Model', &
+ /, ' ==========================')
+ endif
+
+ iwr = 0
+ do ipt = 1, iptx
+ if(IOi_TV(ipt) == 0) IOi_TV(ipt) = imez
+ if(IOj_TV(ipt) == 0) IOi_TV(ipt) = jmez
+ do n = 1, nvx
+ iwr = 1 + iwr
+ if(iwr <= nb_wri) then
+ no__SV(iwr) = 0
+ i___SV(iwr) = IOi_TV(ipt)
+ j___SV(iwr) = IOj_TV(ipt)
+ n___SV(iwr) = n
+ endif
+ enddo
+ enddo
+
+ ! +--Initialization of V10 Interpolation
+ ! + ===================================
+ if(zsigma(1) > 10.) then
+ k = 0
+301 continue
+ k = k + 1
+ if(zsigma(k) < 10 .OR. k > mz) go to 300
+ go to 301
+300 continue
+ kSBL = k
+
+ if(kSBL == mz) then
+ ! 0.002: typical Z0
+ rSBL10 = log(10./0.002) &
+ / log(zsigma(kSBL) / 0.002) !
+ else
+ rSBL10 = (10.-zsigma(kSBL)) &
+ / (zsigma(kSBL - 1) - zsigma(kSBL))
+ endif
+ else
+ kSBL = mz
+ rSBL10 = 1.
+ endif
+
+ erprev = 0.
+ qbs_HY = 0.
+ ! + ++++++
+ endif
+ ! + ++++++ +++ INITIALISATION: END +++
+
+ ! +--Preparation of V10 Interpolation
+ ! + ===================================
+
+ if(kSBL == mz) then
+ do j = 1, my
+ do i = 1, mx
+ VV__10(i, j) = rSBL10 * ssvSL(i, j, kSBL)
+ enddo
+ enddo
+ else
+ do j = 1, my
+ do i = 1, mx
+ VV__10(i, j) = ssvSL(i, j, kSBL) &
+ + rSBL10 * (ssvSL(i, j, kSBL - 1) - ssvSL(i, j, kSBL))
+ enddo
+ enddo
+ endif
+
+ ! +--Preparation of OUTPUT
+ ! + =====================
+
+ ! do n = 1, nvx
+ ! do j = jp11, my1
+ ! do i = ip11, mx1
+ ! WKxyz1(i, j, n) = 0.
+ ! end do
+ ! end do
+ ! end do
+ ! do iwr = 1, nb_wri
+ ! WKxyz1(i___SV(iwr), j___SV(iwr), n___SV(iwr)) = iwr
+ ! end do
+
+ ! +--Update Sea-Ice Fraction
+ ! + ==========================
+
+ if(reaLBC) then
+ ! + ******
+ call INIsic(ihamr_SIS, nhamr_SIS, newsicSI)
+ ! + ******
+ endif
+
+ ! +--Update Green Leaf Fraction
+ ! + ==========================
+#if(GP)
+ glfFIX = .true.
+#endif
+ if(vegmod .and. reaLBC .and. .not. glfFIX) then
+ ! +
+ ! + ******
+ call INIglf(ihamr_SIS, nhamr_SIS, newglfSIS)
+ ! + ******
+ ! +
+ endif
+
+ ! +--SISVAT Time Dependant Variables
+ ! + =================================
+
+#if(VX)
+ ! +--Water Vapor Flux Limitor
+ ! + ------------------------
+ do n = 1, nLimit - 1
+ do j = jp11, my1
+ do i = ip11, mx1
+ WV__SL(i, j, n) = WV__SL(i, j, n + 1)
+ enddo
+ enddo
+ enddo
+ do j = jp11, my1
+ do i = ip11, mx1
+ uqstar = max(abs(SLuqs(i, j)), epsi) * sign(1., SLuqs(i, j))
+ WV__SL(i, j, n) &
+ = TUkvh(i, j, mmz1) * (qvDY(i, j, km2(mz)) - qvDY(i, j, mmz1)) &
+ / (uqstar * (zsigma(km2(mz)) - zsigma(mmz1)))
+ enddo
+ enddo
+ do j = jp11, my1
+ do i = ip11, mx1
+ WVaLim(i, j) = 0.
+ do n = 1, nLimit
+ WVaLim(i, j) = WVaLim(i, j) + WV__SL(i, j, n)
+ enddo
+ WVaLim(i, j) = WVaLim(i, j) / nLimit
+ enddo
+ enddo
+#endif
+
+ ! +--Simple "Mosaic" Rain Disagregation Model
+ ! + ----------------------------------------
+
+ if(mmy <= 1 .and. mw > mw0) then !
+
+ ! +--White Noise Generator
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ if(jhurGE == 6 .and. minuGE == 0 .and. jsecGE == 0) then
+ rtime = tairDY(imez, jmez, mz) * 1.e3
+ ntime = int(rtime)
+ rtime = (rtime - ntime) * 1.e3
+ ntime = rtime
+ ntime = mod(ntime, mw) + 1
+ endif
+
+ ! +--Averaged Soil Humidity
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ ! Averaged Soil Humidity
+ WKxy1(i, j) = 0.
+ do n = 1, mw
+ do k = -nsol, 0
+ WKxy1(i, j) = WKxy1(i, j) &
+ + eta_TV(i, j, n, 1 - k) * dz_dSV(k)
+ enddo
+ enddo
+ WKxy1(i, j) = WKxy1(i, j) / (mw * zz_dSV)
+
+ ! +--Rain Distribution
+ ! + ~~~~~~~~~~~~~~~~~
+ ! Rain Persistance over "wetter" surfaces
+ ! (Taylor et al., 1997, MWR 125, pp.2211-2227)
+ ! Normalization Factor
+ WKxy2(i, j) = 0.
+ do n = 1, mw
+ ! Rain Distribution Arg.
+ ! dry ===> sparse Rain
+ ! Persistance Impact
+ rr__DR(i, j, n) = (mod(mw - n + ntime, mw) + 1) &
+ / (mw * WKxy1(i, j) * WKxy1(i, j)) &
+ * eta_TV(i, j, n, 1) / WKxy1(i, j)
+ rr__DR(i, j, n) = min(rr__DR(i, j, n) &
+ , argmax * 0.1)
+ ! Rain Distribution
+ rr__DR(i, j, n) = exp(-rr__DR(i, j, n))
+ ! mw0 basic Mosaics
+ k = (n - 1) / mw0
+ k = k * mw0 + 1
+ ! Rain Distribution Arg.
+ rr__DR(i, j, n) = rr__DR(i, j, k)
+ ! Normalization Factor
+ WKxy2(i, j) = WKxy2(i, j) &
+ + rr__DR(i, j, n) !
+ enddo !
+
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ do n = 1, mw
+ rr__DR(i, j, n) = rr__DR(i, j, n) * mw &
+ / WKxy2(i, j)
+ enddo
+ enddo
+ enddo
+
+ if(mod(jdarGE, 3) == 0 .and. jhurGE == 6 .and. &
+ minuGE == 0 .and. &
+ jsecGE == 0 .and. &
+ mmy <= 1) then
+ do i = 1, mx
+ if(isolSL(i, 1) > 2) then
+ write(51, 5101) jdarGE, labmGE(mmarGE), iyrrGE, jhurGE, &
+ i,(eta_TV(i, 1, n, 1), n=1, mw)
+5101 format(i3, '-', a3, '-', i4, ':', i2, i6, 15f6.3, /,(21x, 15f6.3))
+ write(51, 5102) &
+ ntime, isolSL(i, 1),(rr__DR(i, 1, n), n=1, mw)
+5102 format(i12, 3x, i6, 15f6.2, /,(21x, 15f6.2))
+ endif
+ enddo
+ write(51, 5103)
+5103 format(111('-'))
+ endif
+ else
+ do j = 1, my
+ do i = 1, mx
+ do n = 1, mw
+ rr__DR(i, j, n) = 1.
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! - Interpolation of temp. and spec. hum. on sub_grid - *CL*
+ ! --------------------------------------------------------------
+
+ do i = 1, mx; do j = 1, my
+ do n = 1, nsx
+ tairDY_int(i, j, n) = tairDY(i, j, mz)
+ qvDY_int(i, j, n) = qvDY(i, j, mz)
+ tairDY_2D(i, j) = tairDY(i, j, mz)
+ qvDY_2D(i, j) = qvDY(i, j, mz)
+ enddo
+ enddo;
+ enddo
+
+ if(mw == 5) then
+ ! + ************************************************************
+ call interp_subpix(tairDY_2D, tairDY_int, 1, -0.01, 0.05 &
+ , gradTM)
+ ! + ************************************************************
+
+ ! + ************************************************************
+ call interp_subpix(qvDY_2D, qvDY_int, 2, -1.0, 1.0 &
+ , gradQM)
+ ! + ************************************************************
+ endif
+
+ ! +--Grid Averages
+ ! + -------------
+
+ !$OMP PARALLEL DO default(shared) &
+ !$OMP private(i,j,k,n,l,ikl,isl,isn,nt,Ua_min,d_snow,SnowOK, &
+ !$OMP rhAir,FraOcn,SrfSIC,SIc0OK,SIceOK,ifra_t, &
+ !$OMP S_Eros,SnEros,dbsnow,k2i,k2j,k2n,itphys) &
+ !$OMP schedule(dynamic)
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ dt__SV = dt
+ ! if(tairdy(i, j, mz)>273.15.and.&
+ ! max(nssSNo(i, j, 1), nssSNo(i, j, mw))>1.)&
+ ! dt__SV = dt / real(ntphys)
+
+ ! if(isolSL(i, j)<=2) dt__SV = dt ! sea or ice
+ ! if(i<=n7.or.j<=n7.or.i>=mx - n6.or.j>=my - n6)&
+ ! dt__SV = dt
+
+ ! +--Surface Fall Line Slope
+ ! + -----------------------
+ ! +
+ if(SnoMod) then
+ if(mx == 1 .and. my == 1) then
+ ! Normalized Decay of the
+ ! Surficial Water Content
+ !(Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
+ SWfSNo(1, 1) = exp(-dt__SV / (c1_zuo + c2_zuo * exp(-c3_zuo * slopTV(1, 1))))
+ else
+ ! Normalized Decay of the
+ ! Surficial Water Content
+ !(Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
+ SWfSNo(i, j) = exp(-dt__SV / (c1_zuo + c2_zuo * exp(-c3_zuo * slopTV(i, j))))
+ endif
+ endif
+
+#if(WR)
+ ifrVER(i, j) = 0
+#endif
+ albeSL(i, j) = 0.
+ eps0SL(i, j) = 0.
+ Upw_IR(i, j) = 0.
+ SLlmo(i, j) = 0.
+ SLuus(i, j) = 0.
+ SLuts(i, j) = 0.
+ SLuqs(i, j) = 0.
+ uss_HY(i, j) = 0.
+ qsrfHY(i, j) = 0.
+#if(iso)
+ do wiso = 1, niso
+ qsrfHY_iso(wiso, i, j) = 0.
+ SLuqs_iso(wiso, i, j) = 0.
+ enddo
+#endif
+ TairSL(i, j) = 0.
+ draiTV(i, j) = 0.
+#if(TC)
+ uqTC(i, j, 1) = 0.
+ qsTC(i, j, 1) = 0.
+#endif
+
+ dzsnSV = 0.
+ ro__SV = 0.
+
+#if(ZA)
+ FracBS = exp(-dt__SV / 43200.)
+#endif
+
+ ! +--Sastrugi Height decreased by Precipitation if V < 6 m/s (Kotlyakov, 1961)
+ ! + --------------------------------------------------------------------------
+
+#if(SZ)
+ dsastr(i, j) = max(0.00,(snowHY(i, j) - sno0HY(i, j)) &
+ / max(0.05, 0.104 * sqrt(max(0.00, VV__10(i, j) - 6.00))))
+#endif
+
+ ! Influence of the Angle(Wind,Sastrugi) (Andreas, 1995, CCREL report 95-16)
+ ! -------------------------------------------------------------------------
+
+#if(ZA)
+ S_Eros = max(zero, sign(unun, -uss_HY(i, j) - eps9))
+ SnEros = max(zero, sign(unun, uss_HY(i, j) + eps9))
+ VVs_BS(i, j) = &
+ SnEros * VVs_BS(i, j) &
+ + S_Eros * (VVs_BS(i, j) * FracBS + &
+ VV__10(i, j))
+ RRs_BS(i, j) = &
+ SnEros * RRs_BS(i, j) &
+ + S_Eros * (RRs_BS(i, j) * FracBS + 1.0)
+ DDs_BS(i, j) = &
+ SnEros * DDs_BS(i, j) &
+ + S_Eros * DDs_BS(i, j) * FracBS &
+ + ((vairDY(i, j, mz) * (uairDY(i, j, mz) - ua_0BS(i, j)) &
+ - uairDY(i, j, mz) * (vairDY(i, j, mz) - va_0BS(i, j)))) &
+ / (degrad * max(0.3, ssvSL(i, j, mz) * ssvSL(i, j, mz)))
+ if(DDs_BS(i, j) > 360.) DDs_BS(i, j) = DDs_BS(i, j) - 360.
+ if(DDs_BS(i, j) < 0.) DDs_BS(i, j) = DDs_BS(i, j) + 360.
+#endif
+
+ ! +--Grid Point Dependant Variables
+ ! + ---------------------------------
+
+ ! +--Verification of Vectorization
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+#if(VR)
+ ij2 = 0
+ do n = 1, mw
+ ij0ver(i, j, n) = 0
+ ij_ver(i, j, n) = 0
+ ijdver(i, j, n) = 0
+ enddo
+#endif
+
+ ! +--SISVAT Variables Update
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^
+ ptopSV = ptopDY
+ do n = 1, mw
+ if(SLsrfl(i, j, n) /= 0) then
+ do ikl = 1, klonv
+ k2i(ikl) = i
+ k2j(ikl) = j
+ k2n(ikl) = n
+ ! Work pt. i Coord.
+ ii__SV(ikl) = i
+ ! Work pt. j Coord.
+ jj__SV(ikl) = j
+ ! Work pt. n Coord.
+ nn__SV(ikl) = n
+
+#if(wz)
+ if(ikl == 1 .and. jsecGE == 0) write(6, 6659)
+6659 format(20x, ' dsn_SV us__SV Z0SaSi Z0Sa_N' &
+ , ' Z0SaSV Z0m_Sn Z0m_SV')
+#endif
+
+ ! +--Atmospheric Forcing (INPUT)
+ ! + ^^^^^^^^^^^^^^^^^^^ ^^^^^
+ ! zSBLSV [m]
+ zSBLSV = z__SBL
+ za__SV(ikl) = (gplvDY(i, j, mz) &
+ - gplvDY(i, j, mzz)) * grvinv
+ VV__SV(ikl) = ssvSL(i, j, mz)
+ VV10SV(ikl) = VV__10(i, j)
+#if(ZA)
+ VVs_SV(ikl) = VVs_BS(i, j) / RRs_BS(i, j)
+ DDs_SV(ikl) = max(zero, DDs_BS(i, j) - 180.) &
+ + 180.*min(unun, zero - min(zero, DDs_BS(i, j) - 180.)) &
+ + min(zero, DDs_BS(i, j) - 180.)
+#endif
+ Ua_min = epsi
+#if(VM)
+ Ua_min = 0.2 * sqrt(za__SV(ikl))
+#endif
+ VV__SV(ikl) = max(Ua_min, ssvSL(i, j, mz))
+ TaT_SV(ikl) = tairDY_int(i, j, n)
+ ExnrSV(ikl) = pkDY(i, j, mz)
+ ! [kg/m3] *CL*
+ rhT_SV(ikl) = (pstDYn(i, j) + ptopDY) * 1.e3 &
+ / (tairDY_int(i, j, n) * RDryAi)
+ QaT_SV(ikl) = qvDY_int(i, j, n)
+ tsrf_SV(ikl) = tsrfSL(i, j, n)
+ pst_SV(ikl) = pstDY(i, j)
+#if(VX)
+ ! Water Vapor Flux Limitor
+ dQa_SV(ikl) = max(0., 1.-WVaLim(i, j)) * dtDiff / zsigma(mz)
+#endif
+ qsnoSV(ikl) = 0.+min(demi, qsHY(i, j, mz))
+
+ ! +--Energy Fluxes (INPUT)
+ ! + ^^^^^^^^^^^^^ ^^^^^
+ ! cos(zenith.Dist.)
+ coszSV(ikl) = max(czemin, czenGE(i, j))
+ ! downward Solar
+ sol_SV(ikl) = RAdsol(i, j)
+ ! downward IR
+ IRd_SV(ikl) = RAd_ir(i, j)
+
+ ! +--Water Fluxes (INPUT)
+ ! + ^^^^^^^^^^^^^ ^^^^^
+ ! [m/s] -> [mm/s] = [kg/m2/s]
+ drr_SV(ikl) = (rainHY(i, j) - rai0HY(i, j)) * 1.e3 &
+ * rr__DR(i, j, n) / dt__SV
+ ! Only SnowFall
+ d_snow = snowHY(i, j) - sfa0HY(i, j)
+ ! Erosion NOT incl.
+ dsn_SV(ikl) = d_snow * 1.e3 / dt__SV
+ ! Correction
+ SnowOK = &
+ max(zero, sign(unun, qsHY(i, j, mz) - epsi)) &
+ * max(zero, min(unun,(rain_snow_limit - 1 - tairDY_int(i, j, n))))
+ dsn_SV(ikl) = dsn_SV(ikl) + drr_SV(ikl) * SnowOK
+ drr_SV(ikl) = drr_SV(ikl) * (1.-SnowOK)
+#if(BS)
+ ! Erosion
+ ! dsnbSV is used and modified in SISVAT_BSn,
+ ! then used for Buffer Layer Update
+ dbsnow = -SLussl(i, j, n) * dt__SV * rhT_SV(ikl)
+ dbs_Ac(ikl) = 0.
+ dbs_Er(ikl) = 0.
+#endif
+ ! +--Soil/Canopy (INPUT)
+ ! + ^^^^^^^^^^^ ^^^^^
+ ! Land/Sea Mask
+ LSmask(ikl) = 1 - maskSL(i, j)
+ ! Soil Type
+ isotSV(ikl) = isolTV(i, j)
+ ! Soil Drainage
+ iWaFSV(ikl) = iWaFTV(i, j)
+ ! Fall Line Slope
+ slopSV(ikl) = atan(slopTV(i, j))
+ ! Soil Albedo
+ alb0SV(ikl) = AlbSTV(i, j)
+ ! Vegetation Type
+ ivgtSV(ikl) = ivegTV(i, j, n)
+ ! LAI
+ LAI0SV(ikl) = alaiTV(i, j, n)
+ ! Green Leaf Frac.
+ glf0SV(ikl) = glf_TV(i, j, n)
+ wem_SV(ikl) = 0.
+ wer_SV(ikl) = 0.
+ wee_SV(ikl, :) = 0.
+
+ ! +--Energy Fluxes (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^ ^^^^^^^^^^^^
+ ! Cloudiness
+ cld_SV(ikl) = cld_SL(i, j)
+ ! Soil upward IR
+ IRs_SV(ikl) = IRsoil(i, j, n)
+ ! Monin-Obukhov L.
+ LMO_SV(ikl) = SLlmol(i, j, n)
+ ! Frict. Velocity
+ us__SV(ikl) = SLuusl(i, j, n)
+ ! u*T*
+ uts_SV(ikl) = SLutsl(i, j, n)
+
+ ! +--Water Fluxes (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^ ^^^^^^^^^^^^
+ ! u*q*
+ uqs_SV(ikl) = SLuqsl(i, j, n)
+#if(iso)
+ do wiso = 1, niso
+ uqs_SV_iso(wiso, ikl) = SLuqsl_iso(wiso, i, j, n)
+ enddo
+#endif
+#if(AE)
+ ! u*_th
+ usthSV(ikl) = SaltSN(i, j, n)
+#endif
+
+ ! +--Soil/Canopy (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^ ^^^^^^^^^^^^
+ ! Moment.Roughn.L.
+ Z0m_SV(ikl) = SL_z0(i, j, n)
+ ! Heat Roughn.L.
+ Z0h_SV(ikl) = SL_r0(i, j, n)
+#if(OR)
+ ! Orogr. Roughn.L.
+ Z0roSV(ikl) = SLzoro(i, j, n)
+#endif
+ ! Vegetation Temp.
+ TvegSV(ikl) = TvegTV(i, j, n)
+ ! Canopy SnowCover
+ snCaSV(ikl) = CaSnTV(i, j, n)
+ ! Canopy RainWater
+ rrCaSV(ikl) = CaWaTV(i, j, n)
+ ! Vegetation Pot.
+ psivSV(ikl) = psivTV(i, j, n)
+ do isl = -nsol, 0
+ ! Soil Temperature
+ TsisSV(ikl, isl) = TsolTV(i, j, n, 1 - isl)
+ ! Soil Humidity
+ eta_SV(ikl, isl) = eta_TV(i, j, n, 1 - isl)
+ enddo
+ enddo
+
+ ! +--Snow Roughness (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^^ ^^^^^^^^^^^^
+ do ikl = 1, klonv
+ ! +--Verification of Vectorization
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+#if(VR)
+ if(ijn <= ijnmax) then
+ ij0ver(i, j, n) = ij0ver(i, j, n) + 1
+ ijdver(i, j, n) = ijdver(i, j, n) + ij
+ endif
+#endif
+
+ Z0mmSV(ikl) = 0. !
+ Z0emSV(ikl) = 0. !
+ Z0hmSV(ikl) = 0. !
+ do nt = 1, ntavSL
+ Z0mmSV(ikl) = Z0mmSV(ikl) &
+ + SLn_z0(i, j, n, nt)
+ Z0emSV(ikl) = Z0emSV(ikl) &
+ + SLn_b0(i, j, n, nt)
+ Z0hmSV(ikl) = Z0hmSV(ikl) &
+ + SLn_r0(i, j, n, nt)
+ enddo
+ ! z0(Mom., Box Av.)
+ Z0mmSV(ikl) = min(Z0mmSV(ikl) / ntavSL, zsigma(mz) / 3.)
+ ! z0(Eros, Box Av.)
+ Z0emSV(ikl) = Z0emSV(ikl) / ntavSL
+ ! z0(Heat, Box Av.)
+ Z0hmSV(ikl) = Z0hmSV(ikl) / ntavSL
+
+#if(SZ)
+ ! z0(Sastrugi h)
+ Z0SaSV(ikl) = Z0SaBS(i, j, n)
+#endif
+#if(SZ)
+ ! dz0(Sastrugi dh)
+ dz0_SV(ikl) = .01 * dsastr(i, j) * max(2 - n, 0)
+#endif
+
+ ! +--V, dT(a-s) Time Moving Averages
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do nt = 1, ntaver
+ V__mem(ikl, nt) = V_0aSL(i, j, nt)
+ T__mem(ikl, nt) = dT0aSL(i, j, n, nt)
+ enddo
+
+ do nt = 1, ntaver - 1
+ V__mem(ikl, nt) = V__mem(ikl, nt + 1)
+ T__mem(ikl, nt) = T__mem(ikl, nt + 1)
+ enddo
+ V__mem(ikl, ntaver) = VV__SV(ikl)
+ T__mem(ikl, ntaver) = TaT_SV(ikl) - tsrfSL(i, j, n)
+
+ VVmmem(ikl) = 0.0
+ dTmmem(ikl) = 0.0
+ do nt = 1, ntaver
+ VVmmem(ikl) = VVmmem(ikl) + V__mem(ikl, nt)
+ dTmmem(ikl) = dTmmem(ikl) + T__mem(ikl, nt)
+ enddo
+ VVmmem(ikl) = VVmmem(ikl) / ntaver
+ dTmmem(ikl) = dTmmem(ikl) / ntaver
+
+ ! +--u*, u*T*, u*s* Time Moving Averages
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(AM)
+ do nt = 1, ntaver
+ u__mem(ikl, nt) = u_0aSL(i, j, n, nt)
+#if(AT)
+ uT_mem(ikl, nt) = uT0aSL(i, j, n, nt)
+#endif
+#if(AS)
+ us_mem(ikl, nt) = us0aSL(i, j, n, nt)
+#endif
+ enddo
+#endif
+ enddo
+
+#if(BS)
+ do ikl = 1, klonv
+ Z0emBS(i, j, n) = Z0emSV(ikl)
+ enddo
+#endif
+
+ ! +--Snow Pack (INPUT/OUTPUT)
+ ! + ^^^^^^^^^ ^^^^^^^^^^^^
+ do ikl = 1, klonv
+#if(AO)
+ !weightA0= 1 if full MAR, 1> weightao>0 if transition, 0 for NEMO coupling area
+ AOmask = weightao_al(i, j)
+ albAOsisv(ikl) = albAO(i, j, n)
+#endif
+ ! Snow Buffer Lay.
+ BufsSV(ikl) = snohSN(i, j, n)
+ dsn_SV(ikl) = dsn_SV(ikl) &
+ + max(BufsSV(ikl) - SMndSV, 0.) &
+ / dt__SV
+ BufsSV(ikl) = min(BufsSV(ikl), SMndSV)
+ ! Snow Buffer dens.
+ BrosSV(ikl) = BrosSN(i, j, n)
+ ! Snow Buffer D./S.
+ BG1sSV(ikl) = BG1sSN(i, j, n)
+ ! Snow Buffer S./S.
+ BG2sSV(ikl) = BG2sSN(i, j, n)
+ ! Nb Snow/Ice L
+ isnoSV(ikl) = min(nsno, max(0, nssSNo(i, j, n)))
+ ! Nb Supr.Ice L
+ ispiSV(ikl) = min(isnoSV(ikl), max(0, issSNo(i, j, n)))
+ ! Nb Ice L
+ iiceSV(ikl) = min(isnoSV(ikl), max(0, nisSNo(i, j, n)))
+ ! Non-Erod.*Thick.
+ zWEcSV(ikl) = zWEcSN(i, j, n)
+ ! Surficial Water
+ rusnSV(ikl) = SWaSNo(i, j, n)
+ ! Surficial Wat.St.
+ SWS_SV(ikl) = SWSSNo(i, j, n)
+ ! Normalized Decay
+ SWf_SV(ikl) = SWfSNo(i, j)
+ enddo
+ do ikl = 1, klonv
+ do isn = 1, nsno
+ ! istoSV [-]
+ istoSV(ikl, isn) = nhsSNo(i, j, n, isn)
+ ! dzsnSV [m]
+ dzsnSV(ikl, isn) = dzsSNo(i, j, n, isn)
+ ! ro__SV [kg/m3]
+ ro__SV(ikl, isn) = rosSNo(i, j, n, isn)
+ ! eta_SV [m3/m3]
+ eta_SV(ikl, isn) = wasSNo(i, j, n, isn)
+ ! TsisSV [K]
+ TsisSV(ikl, isn) = tisSNo(i, j, n, isn)
+ ! G1snSV [-] [-]
+ G1snSV(ikl, isn) = max(-G1_dSV, min(G1_dSV, g1sSNo(i, j, n, isn)))
+ ! G2snSV [-] [0.0001 m]
+ G2snSV(ikl, isn) = max(-G1_dSV, min(G1_dSV, g2sSNo(i, j, n, isn)))
+ ! agsnSV [day]
+ agsnSV(ikl, isn) = agsSNo(i, j, n, isn)
+ enddo
+ enddo
+
+ ! Grid Point (OUTPUT)
+ ! ^^^^^^^^^^ ^^^^^^
+#if(wx)
+ kSV_v1 = 0
+#endif
+
+ do ikl = 1, klonv
+ HFraSV(ikl) = 0. ! Frazil Thickness
+
+ ! +--RunOFF Intensity (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^
+ RnofSV(ikl) = 0. ! RunOFF Intensity
+ RuofSV(ikl, :) = 0. ! RunOFF Intensity
+ zn4_SV(ikl) = 0.
+ zn5_SV(ikl) = 0.
+
+ ! Grid Point (OUTPUT)
+ ! ^^^^^^^^^^ ^^^^^^
+#if(wx)
+ if(i == iSV_v1 .and. j == jSV_v1 .and. n == nSV_v1) kSV_v1 = ikl
+#endif
+ ! lwriSV(ikl) = WKxyz1(i, j, n)
+#if(BW)
+ if(lwriSV(ikl) /= 0 .and. iterun > 0) then
+ noUNIT = no__SV(lwriSV(ikl))
+ write(noUNIT, 5012)
+5012 format(/, 1x)
+ write(noUNIT, 5013)
+5013 format(' -----+--------+--------+--------+--------+', &
+ '--------+--------+--------+--------+--------+', &
+ '--------+')
+ write(noUNIT, 5014)
+5014 format(' n | z | qs | V | |', &
+ ' T | TKE^0.5| | | |', &
+ ' |', &
+ /, ' | [m] | [g/kg] | [m/s] | |', &
+ ' [K] | [m/s] | | | |', &
+ ' |')
+ BlowST = 0.
+ k = 0
+5011 continue
+ k = k + 1
+ if(k > mz) go to 5010
+ if(grvinv * gplvDY(i, j, k) - sh(i, j) < 100.) then
+ BlowST = BlowST + ssvSL(i, j, k) * qsHY(i, j, k) &
+ * pstDY(i, j) * dsigm1(k) * 1.e3 * grvinv
+ write(noUNIT, 5015) mzz - k, grvinv * gplvDY(i, j, k) - sh(i, j), &
+ 1.e3 * qsHY(i, j, k), ssvSL(i, j, k), tairDY(i, j, k), &
+ sqrt(ect_TE(i, j, k))
+5015 format(i5, ' |', f7.2, ' |', f7.3, ' |', f7.2, ' |', &
+ 8x, '|', f7.2, ' |', f7.3, ' |', 4(8x, '|'))
+ endif
+ go to 5011
+5010 continue
+ SnowSB = snohSN(i, j, n)
+ if(nssSNo(i, j, n) > 0) then
+ do isn = max(0, nssSNo(i, j, n)), nssSNo(i, j, n)
+ SnowSB = SnowSB &
+ + dzsSNo(i, j, n, isn) * rosSNo(i, j, n, isn)
+ enddo
+ endif
+ write(noUNIT, 5016) BlowST, SnowSB
+5016 format(' * TRANSPORT = ', e12.3, ' kg/m/s', 8x, '|', &
+ ' * BUDGET = ', f12.6, ' mm w.e.|', 2(8x, '|'))
+ write(noUNIT, 5013)
+ endif
+#endif
+#if(v0)
+ ! OUTPUT, for Stand-Alone VERIFICATION
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(i >= 1 .and. i <= mx) then
+ write(50, 5001) iterun, i, j, n, nvc, ikl, &
+ za__SV(ikl), VV__SV(ikl), TaT_SV(ikl), &
+ rhT_SV(ikl), QaT_SV(ikl), qsnoSV(ikl), &
+ coszSV(ikl), sol_SV(ikl), IRd_SV(ikl), &
+ drr_SV(ikl), dsn_SV(ikl), dbs_SV(ikl), &
+ LSmask(ikl), isotSV(ikl), alb0SV(ikl), &
+ IRs_SV(ikl), &
+ ivgtSV(ikl), LAI0SV(ikl), glf0SV(ikl), &
+ TvegSV(ikl), LMO_SV(ikl), us__SV(ikl), &
+ uqs_SV(ikl), uts_SV(ikl), uss_SV(ikl), &
+ snCaSV(ikl), rrCaSV(ikl), psivSV(ikl)
+5001 format(/, 'c #INFO iterun = ', i15, &
+ /, 'c #INFO i,j,n = ', 3i5, &
+ /, 'c #INFO nvc = ', i15, &
+ /, 'c #INFO ikl = ', i15, &
+ /, ' za__SV(ikl) = ', e15.6, &
+ /, ' VV__SV(ikl) = ', e15.6, &
+ /, ' TaT_SV(ikl) = ', e15.6, &
+ /, ' rhT_SV(ikl) = ', e15.6, &
+ /, ' QaT_SV(ikl) = ', e15.6, &
+ /, ' qsnoSV(ikl) = ', e15.6, &
+ /, ' coszSV(ikl) = ', e15.6, &
+ /, ' sol_SV(ikl) = ', e15.6, &
+ /, ' IRd_SV(ikl) = ', e15.6, &
+ /, ' drr_SV(ikl) = ', e15.6, &
+ /, ' dsn_SV(ikl) = ', e15.6, &
+ /, ' dbs_SV(ikl) = ', e15.6, &
+ /, ' LSmask(ikl) = ', i15, &
+ /, ' isotSV(ikl) = ', i15, &
+ /, ' alb0SV(ikl) = ', e15.6, &
+ /, ' IRs_SV(ikl) = ', e15.6, &
+ /, ' ivgtSV(ikl) = ', i15, &
+ /, ' LAI0SV(ikl) = ', e15.6, &
+ /, ' glf0SV(ikl) = ', e15.6, &
+ /, ' TvegSV(ikl) = ', e15.6, &
+ /, ' LMO_SV(ikl) = ', e15.6, &
+ /, ' us__SV(ikl) = ', e15.6, &
+ /, ' uqs_SV(ikl) = ', e15.6, &
+ /, ' uts_SV(ikl) = ', e15.6, &
+ /, ' uss_SV(ikl) = ', e15.6, &
+ /, ' snCaSV(ikl) = ', e15.6, &
+ /, ' rrCaSV(ikl) = ', e15.6, &
+ /, ' psivSV(ikl) = ', e15.6)
+ do isl = -nsol, 0
+ write(50, 5002) isl, TsisSV(ikl, isl), isl, eta_SV(ikl, isl)
+5002 format(' TsisSV(ikl,', i2, ') = ', e15.6, &
+ ' eta_SV(ikl,', i2, ') = ', e15.6)
+ enddo
+ do isl = 1, nsno
+ write(50, 5003) isl, TsisSV(ikl, isl), isl, dzsnSV(ikl, isl)
+5003 format(' TsisSV(ikl,', i2, ') = ', e15.6, &
+ ' dzsnSV(ikl,', i2, ') = ', e15.6)
+ enddo
+ endif
+#endif
+ enddo
+
+ ! +--SISVAT Execution
+ ! + ^^^^^^^^^^^^^^^^
+ ! write(daHost,'(i2,a3,i4,i3,2(a1,i2))')
+ ! . jdarGE,labmGE(mmarGE),iyrrGE,
+ ! . jhurGE,chb,minuGE,chb,jsecGE
+#if(wz)
+ write(6, 6660) jdarGE, mmarGE, iyrrGE, jhurGE, minuGE, jsecGE
+6660 format(2(i2, '-'), 2i4, 2(':', i2), 3x, $)
+#endif
+
+ do ikl = 1, klonv
+#if(BS)
+ ! dbs_SV = Maximum potential erosion amount [kg/m2]
+ ! => Upper bound for eroded snow mass
+ dbs_SV(ikl) = blowSN(i, j, n)
+#endif
+ uss_SV(ikl) = SLussl(i, j, n) ! u*qs* (only for Tv in sisvatesbl.f)
+#if(BS)
+ ! dsnbSV is the drift fraction of deposited snow updated in sisvat.f
+ ! will be used for characterizing the Buffer Layer
+ ! (see update of Bros_N, G1same, G2same, zroOLD, zroNEW)
+ if(dsn_SV(ikl) > eps12 .and. erprev(i, j, n) > eps9) then
+ ! BS neglib. at kb ~100 magl)
+ dsnbSV(ikl) = 1.0 - min(qsHY(i, j, kB) &
+ / max(qshy(i, j, mz), eps9), unun)
+ dsnbSV(ikl) = max(dsnbSV(ikl), erprev(i, j, n) / dsn_SV(ikl))
+ dsnbSV(ikl) = max(0., min(1., dsnbSV(ikl)))
+ else
+ dsnbSV(ikl) = 0.
+ endif
+ if(n == 1) qbs_HY(i, j) = dsnbSV(ikl)
+#endif
+
+ enddo
+ ! + ************
+ ! do itPhys = 1, max(1, nint(dt / dt__SV))
+ call SISVAT(1)
+ ! do ikl = 1, klonv
+ ! dsn_SV(ikl) = 0.
+ ! drr_SV(ikl) = 0.
+ ! end do
+ ! end do
+ ! + ************
+
+ do ikl = 1, klonv
+ SLussl(i, j, n) = 0.
+#if(BS)
+ ! Effective erosion ~u*qs* from previous time step
+ SLussl(i, j, n) = (-dbs_ER(ikl)) / (dt * rhT_SV(ikl))
+ ! New max. pot. Erosion [kg/m2] (further bounded in sisvat_bsn.f)
+ blowSN(i, j, n) = dt * uss_SV(ikl) * rhT_SV(ikl)
+ erprev(i, j, n) = dbs_Er(ikl) / dt__SV
+#endif
+ enddo
+
+ ! +--MAR Variables Update
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+#if(VR)
+ ! +--Verification of Vectorization
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ij2 = ij2 + 1
+ ijdver(i, j, n) = ijdver(i, j, n) - ij2
+ ij_ver(i, j, n) = ij_ver(i, j, n) + 1
+#endif
+ ! +--Energy Fluxes (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^ ^^^^^^^^^^^^
+ ! Soil upward IR
+ IRsoil(i, j, n) = IRs_SV(ikl)
+ ! Monin-Obukhov L.
+ SLlmol(i, j, n) = LMO_SV(ikl)
+ ! Frict. Velocity
+ SLuusl(i, j, n) = us__SV(ikl)
+ ! u*T*
+ SLutsl(i, j, n) = uts_SV(ikl)
+ ! Sens.H.Flux T-Der.
+ SLdSdT(i, j, n) = dSdTSV(ikl)
+#if(NC)
+ ! +--Energy Fluxes (OUTPUT/NetCDF)
+ ! + ^^^^^^^^^^^^^ ^^^^^^^^^^^^^
+ ! Absorb.Sol.Rad.
+ SOsoNC(i, j, n) = SOsoKL(ikl)
+ ! Absorb.IR Rad.
+ IRsoNC(i, j, n) = IRsoKL(ikl)
+ ! HS
+ HSsoNC(i, j, n) = HSsoKL(ikl)
+ ! HL
+ HLsoNC(i, j, n) = HLsoKL(ikl)
+ ! Evaporation
+ HLs_NC(i, j, n) = HLs_KL(ikl)
+ ! Transpiration
+ HLv_NC(i, j, n) = HLv_KL(ikl)
+#endif
+ ! +--Water Fluxes (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! u*q*
+ SLuqsl(i, j, n) = uqs_SV(ikl)
+#if(iso)
+ do wiso = 1, niso
+ ! todo : compute uqs_SV_iso in sisvat
+ ! todo : SLuqsl_iso -> uqs_SV -> HLv_sv + HLs_sv (sisvat.f90)
+ ! todo : HLv_sv (sisvat_tgv) and HLs_sv (sisvat_tso) -> HL___D : store Rsnow ?
+ ! SLuqsl_iso(wiso, i, j, n) = uqs_SV_iso(wiso, ikl)
+ SLuqsl_iso(wiso, i, j, n) = Rdefault(wiso) * uqs_SV(ikl)
+ enddo
+#endif
+ ! Latn.H.Flux T-Der.
+ SLdLdT(i, j, n) = dLdTSV(ikl)
+ enddo
+ do ikl = 1, klonv
+#if(AE)
+ ! u*_th
+ SaltSN(i, j, n) = usthSV(ikl)
+#endif
+ ! +--Soil/Canopy (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! Moment.Roughn.L.
+ SL_z0(i, j, n) = Z0m_SV(ikl)
+ ! Heat Roughn.L.
+ SL_r0(i, j, n) = Z0h_SV(ikl)
+ ! sq.root Contr.Drag
+ cdmSL(i, j, n) = rCDmSV(ikl)
+ ! sq.root Contr.Drag
+ cdhSL(i, j, n) = rCDhSV(ikl)
+ ! Vegetation Temp.
+ TvegTV(i, j, n) = TvegSV(ikl)
+ ! Canopy SnowCover
+ CaSnTV(i, j, n) = snCaSV(ikl)
+ ! Canopy RainWater
+ CaWaTV(i, j, n) = rrCaSV(ikl)
+ ! Vegetation Pot.
+ psivTV(i, j, n) = psivSV(ikl)
+ do isl = -nsol, 0
+ ! Soil Humidity
+ eta_TV(i, j, n, 1 - isl) = eta_SV(ikl, isl)
+ ! Soil Temperature
+ TsolTV(i, j, n, 1 - isl) = TsisSV(ikl, isl)
+ enddo
+ enddo
+ ! +--Snow Roughness (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ do nt = 1, ntavSL - 1
+ SLn_z0(i, j, n, nt) = SLn_z0(i, j, n, nt + 1)
+ SLn_b0(i, j, n, nt) = SLn_b0(i, j, n, nt + 1)
+ SLn_r0(i, j, n, nt) = SLn_r0(i, j, n, nt + 1)
+ enddo
+ enddo
+ do ikl = 1, klonv
+ ! z0(Momentum)
+ SLn_z0(i, j, n, ntavSL) = Z0mnSV(ikl)
+ ! z0(Mom., Erosion)
+ SLn_b0(i, j, n, ntavSL) = Z0enSV(ikl)
+ ! z0(Heat)
+ SLn_r0(i, j, n, ntavSL) = Z0hnSV(ikl)
+#if(SZ)
+ ! z0(Sastrugi h)
+ Z0SaBS(i, j, n) = Z0SaSV(ikl)
+#endif
+ ! +--V, dT(a-s) Time Moving Averages
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do nt = 1, ntaver
+ V_0aSL(i, j, nt) = V__mem(ikl, nt)
+ dT0aSL(i, j, n, nt) = T__mem(ikl, nt)
+ enddo
+#if(AM)
+ ! +--u*, u*T*, u*s* Time Moving Averages
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do nt = 1, ntaver
+ u_0aSL(i, j, n, nt) = u__mem(ikl, nt)
+#if(AT)
+ uT0aSL(i, j, n, nt) = uT_mem(ikl, nt)
+#endif
+#if(AS)
+ us0aSL(i, j, n, nt) = us_mem(ikl, nt)
+#endif
+ enddo
+#endif
+ enddo
+
+#if(BD)
+ ! +--Dust Fluxes (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ ! Snow Free Surface
+ ! DUST Erosion
+ ! Tuning Factor (2D)
+ SLubsl(i, j, n) = (1 - min(1, isnoSV(ikl))) &
+ * uss_SV(ikl) &
+ * max(1,(2 - mmy) * 3)
+ enddo
+#endif
+ ! +--Snow Pack (INPUT/OUTPUT)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ snohSN(i, j, n) = BufsSV(ikl) ! Snow Buffer Lay.
+ BrosSN(i, j, n) = BrosSV(ikl) ! Snow Buffer dens.
+ BG1sSN(i, j, n) = BG1sSV(ikl) ! Snow Buffer D./S.
+ BG2sSN(i, j, n) = BG2sSV(ikl) ! Snow Buffer S./S.
+ nssSNo(i, j, n) = isnoSV(ikl) ! Nb Snow/Ice Lay.
+ issSNo(i, j, n) = ispiSV(ikl) ! Nb Supr.Ice Lay.
+ nisSNo(i, j, n) = iiceSV(ikl) ! Nb Ice Lay.
+ zWE_SN(i, j, n) = zWE_SV(ikl) ! Current *Thick.
+ zWEcSN(i, j, n) = zWEcSV(ikl) ! Non-Erod.*Thick.
+ hSalSN(i, j, n) = hSalSV(ikl) ! Salt.Layer Height
+ SWaSNo(i, j, n) = rusnSV(ikl) ! Surficial Water
+ SWSSNo(i, j, n) = SWS_SV(ikl) ! Surficial Wat.St.
+ enddo
+ do ikl = 1, klonv
+ do isn = 1, nsno
+ nhsSNo(i, j, n, isn) = istoSV(ikl, isn) ! [-]
+ dzsSNo(i, j, n, isn) = dzsnSV(ikl, isn) ! [m]
+ rosSNo(i, j, n, isn) = ro__SV(ikl, isn) ! [kg/m3]
+ wasSNo(i, j, n, isn) = eta_SV(ikl, isn) ! [m3/m3]
+ tisSNo(i, j, n, isn) = TsisSV(ikl, isn) ! [K]
+ g1sSNo(i, j, n, isn) = G1snSV(ikl, isn) ! [-] [-]
+ g2sSNo(i, j, n, isn) = G2snSV(ikl, isn) ! [-] [0.0001 m]
+ agsSNo(i, j, n, isn) = agsnSV(ikl, isn) ! [day]
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ EVSU(i, j, n, :) = wee_SV(ikl, :) ! Evapo/Sublimation
+ WKxyz4(i, j, n) = wem_SV(ikl) ! Melting
+ WKxyz5(i, j, n) = wer_SV(ikl) ! Refreezing
+#if(BS)
+ weerIB(i, j, n) = weerIB(i, j, n) + dbs_Er(ikl) ! BS erosion
+#endif
+ zn4IB(i, j, n) = zn4IB(i, j, n) + zn4_SV(ikl)
+ zn5IB(i, j, n) = zn5IB(i, j, n) + zn5_SV(ikl)
+
+ ! +--Radiative Properties (OUTPUT)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ albxSL(i, j, n) = alb_SV(ikl) ! Mosaic Albedo
+ !Commented !AO_CK 20/02/2020 (bad variable)
+ !c #AO. *(1-maskSL(i,j)) !
+ !c #AO. + albAO(i,j,n) ! Mosaic AlbedoNEMO
+ !c #AO. * maskSL(i,j) !
+ WKxyz6(i, j, n) = emi_SV(ikl) ! Mosaic Emissivity
+ WKxyz7(i, j, n) = IRu_SV(ikl) ! Mosaic Upw.IR
+ WKxyz8(i, j, n) = qSalSV(ikl) ! Saltating Partic.
+ hfra(i, j, n) = HFraSV(ikl) ! Frazil Thickness
+ Rnof(i, j, n) = RnofSV(ikl) ! Run OFF Intensity
+ Ruof(i, j, n, :) = RuofSV(ikl, :) ! Run OFF Intensity
+
+ if(n == 1) then
+ alb1IB(i, j) = alb1SV(ikl)
+ alb2IB(i, j) = alb2SV(ikl)
+ alb3IB(i, j) = alb3SV(ikl)
+ endif
+
+ enddo
+ else
+ Rnof(i, j, n) = 0.
+ Ruof(i, j, n, :) = 0.
+ EVSU(i, j, n, :) = 0.
+ endif
+ enddo
+
+ ! +--Surface Temperature: Prescription of relevant Medium (Snow, precribed SST)
+ ! + ==========================================================================
+
+ do isl = -nsol, 0 !
+ ! +--Open Ocean
+ ! + ----------
+ eta_TV(i, j, 1, 1 - isl) = &
+ eta_TV(i, j, 1, 1 - isl) * (1 - maskSL(i, j)) &
+ + maskSL(i, j) ! Sea: Humidity:=1
+ TsolTV(i, j, 1, 1 - isl) = &
+ ! Soil Temperature
+ ! Prescribed SST
+ (TsolTV(i, j, 1, 1 - isl) * (1 - maskSL(i, j)) &
+ + sst_LB(i, j) * maskSL(i, j))
+#if(OP)
+ ! cCA : OP is weird and not activated
+ TsolTV(i, j, 1, 1 - isl) = TsolTV(i, j, 1, 1 - isl) * FixSST + &
+ (TsolTV(i, j, 1, 1 - isl) &
+ !~Prescribed SST
+ + (sst_LB(i, j) - &
+ ! (Nudging)
+ TsolTV(i, j, 1, 1 - isl)) * maskSL(i, j) * SSTnud &
+ ! Interactive SST
+ ) * VarSST
+#endif
+#if(AO)
+ ! +--Sea Ice
+ ! + -------
+ ! AO_CK 20/02/2020 tissno is now modified before the call of sisvat (in oasis_2_mar.f)
+ ! Sea: Humidity:=0
+ eta_TV(i, j, 2, 1 - isl) = eta_TV(i, j, 2, 1 - isl) * (1 - maskSL(i, j))
+ ! Soil Temperature + Prescribed ST
+ TsolTV(i, j, 2, 1 - isl) = &
+ (TsolTV(i, j, 2, 1 - isl) * (1 - maskSL(i, j)) &
+ + 271.2 * maskSL(i, j))
+#endif
+ enddo
+
+ do n = 1, mw
+ ! Surf.Temperature
+ tsrfSL(i, j, n) = TsolTV(i, j, n, 1) &
+ * (1 - min(1, nssSNo(i, j, n))) &
+ + tisSNo(i, j, n, max(1, nssSNo(i, j, n))) &
+ * min(1, nssSNo(i, j, n))
+#if(NC)
+ eta_NC(i, j, n) = 0.
+ do isl = -nsol, 0
+ ! Soil Moisture
+ eta_NC(i, j, n) = eta_NC(i, j, n) &
+ + eta_TV(i, j, n, 1 - isl) * dz_dSV(isl)
+ enddo
+#endif
+ enddo
+
+ ! +--Mosaic Cleaning
+ ! + ===============
+
+ if(maskSL(i, j) == 1) then
+ if(nssSNo(i, j, 1) > 0) then
+ nssSNo(i, j, 1) = 0
+ issSNo(i, j, 1) = 0
+ nisSNo(i, j, 1) = 0
+ do isl = 1, nsno
+ tisSNo(i, j, 1, isl) = 0.
+ dzsSNo(i, j, 1, isl) = 0.
+ rosSNo(i, j, 1, isl) = 0.
+ wasSNo(i, j, 1, isl) = 0.
+ g1sSNo(i, j, 1, isl) = 0.
+ g2sSNo(i, j, 1, isl) = 0.
+ agsSNo(i, j, 1, isl) = 0.
+ nhsSNo(i, j, 1, isl) = 0.
+ enddo
+ endif
+ if(SLsrfl(i, j, 2) < eps9 .and. tsrfSL(i, j, 2) /= tsrfSL(i, j, 1)) then
+ tsrfSL(i, j, 2) = tsrfSL(i, j, 1)
+ do isl = 1, nsol + 1
+ TsolTV(i, j, 2, isl) = TsolTV(i, j, 1, isl)
+ ENDdo !#n2
+ nssSNo(i, j, 2) = nssSNo(i, j, 1) * (1 - maskSL(i, j))
+ issSNo(i, j, 2) = issSNo(i, j, 1) * (1 - maskSL(i, j))
+ nisSNo(i, j, 2) = nisSNo(i, j, 1) * (1 - maskSL(i, j))
+ do isl = 1, nsno !
+ tisSNo(i, j, 2, isl) = tisSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ dzsSNo(i, j, 2, isl) = dzsSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ rosSNo(i, j, 2, isl) = rosSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ wasSNo(i, j, 2, isl) = wasSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ g1sSNo(i, j, 2, isl) = g1sSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ g2sSNo(i, j, 2, isl) = g2sSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ agsSNo(i, j, 2, isl) = agsSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ nhsSNo(i, j, 2, isl) = nhsSNo(i, j, 1, isl) * (1 - maskSL(i, j))
+ ENDdo !#n2
+ endif !#n2
+ endif
+
+ ! +--Grid Averages / Diagnostics
+ ! + ===========================
+
+ ! +--Grid Averages (OUTPUT)
+ ! + ^^^^^^^^^^^^^ ^^^^^^
+ do n = 1, mw
+ wee_IB(i, j, n, :) = EvSU(i, j, n, :) + wee_IB(i, j, n, :) ! evapotrans
+ wem_IB(i, j, n) = WKxyz4(i, j, n) + wem_IB(i, j, n) ! Melting
+ wer_IB(i, j, n) = WKxyz5(i, j, n) + wer_IB(i, j, n) ! Refreezing
+ ! Runoff
+ weu_IB(i, j, n) = Rnof(i, j, n) * dt__SV &
+ + weu_IB(i, j, n)
+ weo_IB(i, j, n, :) = Ruof(i, j, n, :) * dt__SV &
+ + weo_IB(i, j, n, :)
+
+#if(WR)
+ ifrVER(i, j) = ifrVER(i, j) + ifraTV(i, j, n)
+#endif
+ ! albeSL : Grid Albedo + Mosaic Albedo
+ albeSL(i, j) = albeSL(i, j) + SLsrfl(i, j, n) * albxSL(i, j, n)
+ ! eps0SL : Grid Emissivity + Mosaic Emissivity
+ eps0SL(i, j) = eps0SL(i, j) + SLsrfl(i, j, n) * WKxyz6(i, j, n)
+ ! Upw_IR : + Mosaic Upw.IR
+ Upw_IR(i, j) = Upw_IR(i, j) + SLsrfl(i, j, n) * WKxyz7(i, j, n)
+ ! SLlmo : + Mosaic Mon.Ob.
+ SLlmo(i, j) = SLlmo(i, j) + SLsrfl(i, j, n) * SLlmol(i, j, n)
+ ! SLuus : Grid u* + Mosaic u*
+ SLuus(i, j) = SLuus(i, j) + SLsrfl(i, j, n) * SLuusl(i, j, n)
+ ! SLuts : Grid u*T* + Mosaic u*T*
+ SLuts(i, j) = SLuts(i, j) + SLsrfl(i, j, n) * SLutsl(i, j, n)
+ ! SLuqs : Grid u*q* + Mosaic u*q*
+ SLuqs(i, j) = SLuqs(i, j) + SLsrfl(i, j, n) * SLuqsl(i, j, n)
+#if(iso)
+ do wiso = 1, niso
+ SLuqs_iso(wiso, i, j) = SLuqs_iso(wiso, i, j) + SLsrfl(i, j, n) * SLuqsl_iso(wiso, i, j, n)
+ enddo
+#endif
+#if(BS)
+ ! Grid u*s* + Mosaic u*s*
+ uss_HY(i, j) = uss_HY(i, j) + SLsrfl(i, j, n) * SLussl(i, j, n)
+#endif
+ ! u*s*
+ ! +...NO ! SLussl(i,j,n) = uss_SV(ikl)
+ ! + Upper Update = wrong Source of Atmospher.Snow!
+#if(BS)
+ ! Salt.Part.Concent., only if there is a snow layer
+ qsrfHY(i, j) = qsrfHY(i, j) + SLsrfl(i, j, n) * WKxyz8(i, j, n) * min(1, nssSNo(i, j, n))
+#endif
+#if(PO)
+ ! Frazil Thickness
+ HFraPO(i, j) = HFraPO(i, j) + SLsrfl(i, j, n) * HFra(i, j, n)
+#endif
+ ! Surface Air Temperature
+ TairSL(i, j) = TairSL(i, j) + SLsrfl(i, j, n) * tsrfSL(i, j, n)
+ ! Run OFF Intensity
+ draiTV(i, j) = draiTV(i, j) + SLsrfl(i, j, n) * Rnof(i, j, n)
+#if(TC)
+ ! Grid u*b* + Mosaic u*b*
+ uqTC(i, j, 1) = uqTC(i, j, 1) + SLsrfl(i, j, n) * SLubsl(i, j, n)
+ ! Salt.Part.Concent.
+ qsTC(i, j, 1) = qsTC(i, j, 1) + SLsrfl(i, j, n) * WKxyz8(i, j, n) * (1 - min(1, nssSNo(i, j, n)))
+#endif
+ enddo
+ sno0HY(i, j) = snowHY(i, j)
+ pktaSL(i, j) = TairSL(i, j) / exp(cap * log(pstDY(i, j) + ptopDY))
+ ! Brightness Temp.
+ tviRA(i, j) = sqrt(sqrt(Upw_IR(i, j) / stefan))
+ ! Air Densitity
+ rhAir = rolvDY(i, j, mz) * 1.e3
+ ! Sensible Heat Flux
+ hsenSL(i, j) = -SLuts(i, j) * rhAir * cp
+ ! Surf.Specif.Humid. [to adapt over soil]
+ qvapSL(i, j) = qvsiDY(i, j, mzz)
+#if(iso)
+ ! todo : compute Riso of the vapor in equilibrium with the surface
+ ! todo : get Riso of snow / water + fractcalk
+ ! todo : Riso of snow from dzsSNo = dzsnSV
+ ! todo : Riso of water from wasSNo_iso (negligible?) and SWaSNo_iso (?) + mixing of the two ?
+ do wiso = 1, niso
+ qvapSL_iso(wiso, i, j) = Rdefault(wiso) * qvapSL(i, j)
+ enddo
+#endif
+ ! Latent Heat Flux
+ hlatSL(i, j) = -SLuqs(i, j) * rhAir * Lv_H2O
+ ! Total Evaporat. [mm w.e.]
+ evapTV(i, j) = evapTV(i, j) - SLuqs(i, j) * rhAir * dt__SV
+#if(iso)
+ ! todo : evapTV_iso -> compute Riso
+ ! todo : need to track SLuqs -> SLuqsl_iso -> see above
+ do wiso = 1, niso
+ evapTV_iso(wiso, i, j) = Rdefault(wiso) * evapTV(i, j)
+ enddo
+#endif
+ ! Integrated Run OFF
+ runoTV(i, j) = runoTV(i, j) + draiTV(i, j) * dt__SV
+ firmSL(i, j) = Upw_IR(i, j)
+
+ ! +--Sea-Ice Ice Floe Size
+ ! + =====================
+
+ ! +--Prescription from SST
+ ! + ---------------------
+
+ if(VarSST <= epsi .and. maskSL(i, j) == 1) then
+ ! Prescribed from SST (not use anymore by anyone CK 20/02/20)
+ ! FraOcn = (TsolTV(i,j,1,1)-Tfr_LB)/TSIdSV
+ ! Prescribed from rea/ocean model
+ FraOcn = 1.-sicsIB(i, j)
+
+ ! UpperLimit
+ FraOcn = min(unun, FraOcn)
+ ! LowerLimit
+ FraOcn = max(OcnMin, FraOcn)
+ ! New Ocean (ocean % at current dt)
+ SLsrfl(i, j, 1) = FraOcn
+ ! Old Sea Ice (SIC at previous dt)
+ SrfSIC = SLsrfl(i, j, 2)
+ ! 1 if SICdt-1 > epsi ; 0 if SICdt-1<epsi
+ SIc0OK = max(zero, sign(unun, SrfSIC - epsi))
+ ! New Sea ice (SIC at current dt)
+ SLsrfl(i, j, 2) = 1.-FraOcn
+ ! 1 if SICdt > epsi ; 0 if Sidct < epsi
+ SIceOK = max(zero, sign(unun, SLsrfl(i, j, 2) - epsi))
+ ! OCN Fraction
+ ifra_t = ifraTV(i, j, 1) + ifraTV(i, j, 2)
+ ifraTV(i, j, 1) = SLsrfl(i, j, 1) * 100.
+ ifraTV(i, j, 1) = min(ifraTV(i, j, 1), ifra_t)
+ ifraTV(i, j, 2) = ifra_t - ifraTV(i, j, 1)
+
+ ! +--Sea-Ice Vertical Discretization
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! if no sic dt 0, if SIC dt then
+ ! if SICdt-1 then at least 1 layer or number of the dt-1 layers >1
+ ! if not SICdt-1 then 3 layers
+ nssSNo(i, j, 2) = &
+ (max(1 &
+ , nssSNo(i, j, 2)) * SIc0OK &
+ + 3 * (1.-SIc0OK) * SIceOK)
+ ! +
+ nisSNo(i, j, 2) = &
+ (max(1 &
+ , nisSNo(i, j, 2)) * SIc0OK &
+ + 3 * (1.-SIc0OK) * SIceOK)
+ issSNo(i, j, 2) = nisSNo(i, j, 2)
+ ! +
+ do l = 1, nsno
+ ! If SIC dt then
+ ! if SICdt-1 then at least the bottom layer
+ ! with 10cm or any value > 10cm (dt-1 thickness for all the other old layers)
+ ! if not SICdt-1 then 4 layers of 0.5,0.05,0.001,0.0/ m (=> 3 real layers)
+ dzsSNo(i, j, 2, l) = &
+ (max &
+ (SIc_OK(min(2, l)) * SIcMIN &
+ , dzsSNo(i, j, 2, l)) * SIc0OK &
+ + dzSIce(min(4, l)) * (1.-SIc0OK) * SIceOK)
+ ! +
+ tisSNo(i, j, 2, l) = &
+ (tisSNo(i, j, 2, l) * SIc0OK &
+ + TsolTV(i, j, 1, 1) * (1.-SIc0OK))
+ ! +
+ ! If sicdt then
+ ! If SICdt-1 then at least the bottom layer
+ ! with 920 or any value of the sea ice pack >920 (dt-1 ro for all the other old layers)
+ ! if not SICdt-1 then 920 for all new layers
+ rosSNo(i, j, 2, l) = &
+ (max &
+ (SIc_OK(min(2, l)) * ro_Ice &
+ , rosSNo(i, j, 2, l)) * SIc0OK &
+ + ro_Ice * (1.-SIc0OK) * SIceOK)
+ ! +
+ g1sSNo(i, j, 2, l) = &
+ (g1sSNo(i, j, 2, l) * SIc0OK &
+ + G1_dSV * (1.-SIc0OK) * SIceOK)
+ ! +
+ g2sSNo(i, j, 2, l) = &
+ (g2sSNo(i, j, 2, l) * SIc0OK &
+ + 30.*(1.-SIc0OK) * SIceOK)
+ ! +
+ nhsSNo(i, j, 2, l) = istdSV(2)
+#if(SInew)
+ nhsSNo(i, j, 2, l) = nhsSNo(i, j, 2, l) + &
+ (nhsSNo(i, j, 2, l) * SIc0OK + &
+ istdSV(2) * (1.-SIc0OK) * SIceOK) * maskSL(i, j)
+#endif
+
+ enddo
+
+#if(AO)
+ ! COUPLING AO_CK! 20/02/2020
+ if(weightAO_sit(i, j) == 0) then !full NEMO
+ ! coupling of sea ice thickness from NEMO
+ if(aohic > 0) then !coupling time step
+ zntot = 0.
+ do l = 1, nsno
+ ! zntot of ice layers
+ if(rosSNo(i, j, 2, l) > 900 .and. dzsSNo(i, j, 2, l) > 0) then
+ zntot = zntot + dzsSNo(i, j, 2, l)
+ endif
+ enddo
+ do l = 1, nsno
+ ! NEMO minimal sea ice thickness is 10cm as in MAR
+ if(rosSNo(i, j, 2, l) > 900 .and. dzsSNo(i, j, 2, l) > 0 &
+ .and. hicAO(i, j) >= 0.1 .and. zntot > 0) then
+ dzsSNo(i, j, 2, l) = dzsSNo(i, j, 2, l) * hicAO(i, j) / zntot
+ endif
+ enddo
+ endif
+ endif
+ ! end coupling AO_CK SEA ICE THICKNESS 20/02/2020
+ ! coupling of snow thickness on the sea ice from NEM
+ ! full NEMO
+ if(weightAO_snt(i, j) == 0) then
+ if(aohsn > 0) then !coupling time ste
+ if(SIc0OK == 1 .and. SIceOK == 1) then
+ ! Sea ice at previous time step and at the current time step
+ ! => changes the thickness of the snow by applying a ratio
+ zntot = 0.
+ do l = 1, nsno
+ ! zntot of snow layers
+ if(rosSNo(i, j, 2, l) < 900 .and. dzsSNo(i, j, 2, l) > 0) then
+ zntot = zntot + dzsSNo(i, j, 2, l)
+ endif
+ enddo
+ do l = 1, nsno
+ if(rosSNo(i, j, 2, l) < 900 .and. dzsSNo(i, j, 2, l) > 0 &
+ .and. zntot > 0 .and. nssSNo(i, j, 2) > 1) then
+ if(hsnoAO(i, j) >= 0.005) then
+ ! ratio new/old
+ dzsSNo(i, j, 2, l) = dzsSNo(i, j, 2, l) * hsnoAO(i, j) / zntot
+ else
+ ! if NEMO snow thickness lower than minimal snow thickness in MAR => 0 ?
+ dzsSNo(i, j, 2, l) = 0.
+ nssSNo(i, j, 2) = max(3., nssSNo(i, j, 2) - 1.)
+ endif
+ endif
+ enddo
+ endif
+ if(SIc0OK == 0 .and. SIceOK == 1 &
+ .and. hsnoAO(i, j) >= 0.005) then
+ !No sea ice at the previous time step but new sea ice at the current time step
+ !+1 one snow layer
+ nssSNo(i, j, 2) = nssSNo(i, j, 2) + 1.
+ ! snow thickness from NEMO
+ dzsSNo(i, j, 2, int(nssSNo(i, j, 2))) = hsnoAO(i, j)
+ ! temp neige/surface from NEMO
+ tisSNo(i, j, 2, int(nssSNo(i, j, 2))) = 270.
+ ! density from NEMO
+ rosSNo(i, j, 2, int(nssSNo(i, j, 2))) = 300.
+ ! G1 fresh snow
+ g1sSNo(i, j, 2, int(nssSNo(i, j, 2))) = G1_dSV
+ ! G2 fresh snow
+ g2sSNo(i, j, 2, int(nssSNo(i, j, 2))) = 30.
+ ! faceted cristal
+ nhsSNo(i, j, 2, int(nssSNo(i, j, 2))) = istdSV(1)
+ endif
+ endif
+ endif
+ ! end coupling AO_CK SNOW THICKNESS 20/02/2020
+#endif
+
+ do l = 1, llx
+ TsolTV(i, j, 2, l) = &
+ TsolTV(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + (TsolTV(i, j, 2, l) * SIc0OK &
+ + TsolTV(i, j, 1, l) * (1.-SIc0OK)) * maskSL(i, j)
+ ! +
+ eta_TV(i, j, 2, l) = &
+ eta_TV(i, j, 2, l) * (1 - maskSL(i, j)) &
+ + eta_TV(i, j, 2, l) * SIc0OK * maskSL(i, j)
+ ! +... No Pore in Ice => No Water
+ enddo
+ ! +
+#if(WI)
+ write(6, 6001) jdarGE, labmGE(mmarGE), iyrrGE &
+ , jhurGE, minuGE, jsecGE, TsolTV(i, j, 1, 1) &
+ , FraOcn, ifraTV(i, j, 1), TsolTV(i, j, 2, 1) &
+ , nisSNo(i, j, 2), nssSNo(i, j, 2)
+#endif
+ ! +
+ endif
+
+ ! +--Otherwise SST and FrLead have been computed in the Sea-Ice Polynya Model
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ ! +--Rainfall, Snowfall Time Integral at previous Time Step
+ ! + ------------------------------------------------------
+
+ rai0HY(i, j) = rainHY(i, j) ! Rainfall Time Integral
+ sfa0HY(i, j) = snowHY(i, j) ! Snowfall Time Integral
+
+ ! Wind Horizontal Components at previous Time Step
+ ! --------------------------------------------------------
+
+#if(ZA)
+ ua_0BS(i, j) = uairDY(i, j, mz)
+ va_0BS(i, j) = vairDY(i, j, mz)
+#endif
+
+ ! +--Work Array Reset
+ ! + ================
+
+ WKxy1(i, j) = 0.
+ WKxy2(i, j) = 0.
+ WKxy3(i, j) = 0.
+ WKxy5(i, j) = 0.
+ WKxy6(i, j) = 0.
+ WKxy7(i, j) = 0.
+
+ do k = 1, mw
+ WKxyz1(i, j, k) = 0.
+ WKxyz2(i, j, k) = 0.
+ WKxyz3(i, j, k) = 0.
+ WKxyz4(i, j, k) = 0.
+ WKxyz5(i, j, k) = 0.
+ WKxyz6(i, j, k) = 0.
+ WKxyz7(i, j, k) = 0.
+ WKxyz8(i, j, k) = 0.
+ enddo
+
+ ENDdo !i
+ ENDdo !j
+ !$OMP END PARALLEL DO
+
+ ! +--Blown Snow/Dust Accumulation
+ ! + ============================
+
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(wx)
+ if(lSV_v1 == 2) write(6, 6011) uss_HY(iSV_v1, jSV_v1) * 1.e3
+6011 format(10x, 'After SISVAT(1): us* [mm/s] =', f9.3)
+#endif
+
+ !c #BS do i=ip11,mx1
+ !c #BS do j= 1,my
+ !c #BS WKxy6(i ,j ) =
+ !c #BS& uss_HY(im1(i),j )+2.0*uss_HY(i ,j )
+ !c #BS& + uss_HY(ip1(i),j )
+ !c #BS end do
+ !c #BS end do
+
+ !c #BS do j=jp11,my1
+ !c #BS do i=ip11,mx1
+ !c #BS WKxy5(i ,j ) = WKxy6(i ,jm1(j))
+ !c #BS WKxy7(i ,j ) = WKxy6(i ,jp1(j))
+ !c #BS end do
+ !c #BS end do
+
+ !c#BS do j=jp11,my1
+ !c#BS do i=ip11,mx1
+ !c#BS uss_HY(i ,j ) =
+ !c#BS. WKxy7(i ,j )
+ !c#BS. + WKxy6(i ,j ) + WKxy6(i ,j )
+ !c#BS. + WKxy5(i ,j )
+
+ ! Previous three Loops Stand for the following unvectorized Loop:
+ ! WKxy2(i,j) = uss_HY(im1(i),jp1(j))
+ ! . +2.d0*uss_HY(i ,jp1(j)) + uss_HY(ip1(i),jp1(j))
+ ! . +2.d0*uss_HY(im1(i),j)
+ ! . +4.d0*uss_HY(i ,j) +2.d0*uss_HY(ip1(i),j)
+ ! . + uss_HY(im1(i),jm1(j))
+ ! . +2.d0*uss_HY(i ,jm1(j)) + uss_HY(ip1(i),jm1(j))
+ !c#BS end do
+ !c#BS end do
+
+ !c #BD do i=1,mx
+ !c #BD do j=1,my
+ !c #BD WKxy3(i,j) = uqTC(im1(i),jp1(j),1)
+ !c #BD. +2.d0*uqTC(i ,jp1(j),1) + uqTC(ip1(i),jp1(j),1)
+ !c #BD. +2.d0*uqTC(im1(i),j ,1)
+ !c #BD. +4.d0*uqTC(i ,j ,1) +2.d0*uqTC(ip1(i),j ,1)
+ !c #BD. + uqTC(im1(i),jm1(j),1)
+ !c #BD. +2.d0*uqTC(i ,jm1(j),1) + uqTC(ip1(i),jm1(j),1)
+ !c #BD end do
+ !c #BD end do
+
+ !c #BS do j=1,my
+ !c #BS do i=1,mx
+ !c #BS WKxy5(i,j) = 0.
+ !c #BS WKxy6(i,j) = 0.
+ !c #BS end do
+ !c #BS end do
+
+ !spatial smoothing commented - C.Amory BS 2018
+ !c #BS do j=jp11,my1
+ !c #BS do i=ip11,mx1
+ !c #BS do k=-1,1 ; do n=-1,1
+ !c #BS uu= 1 ; vv=1
+ !c #BS if(sign(1., uairdy(i,j,mz))/=sign(1.,real(k)))
+ !c #BS. uu=sqrt(abs(uairdy(i,j,mz)))
+ !c #BS if(sign(1., vairdy(i,j,mz))/=sign(1.,real(n)))
+ !c #BS. vv=sqrt(abs(vairdy(i,j,mz)))
+ !c #BS uu=max(1.,min(4.,uu))
+ !c #BS vv=max(1.,min(4.,vv))
+ !c #BS ww=1.
+ !c #BS if(n==0) ww=uu
+ !c #BS if(k==0) ww=vv
+ !c #BS if(n==0.and.k==0) ww=(uu+vv)*2.
+ !c #BS if(abs(k)==1.and.abs(n)==1) ww=(uu+vv)/2.
+ !c #BS WKxy5(i,j)=WKxy5(i,j)+ww*uss_HY(i+k,j+n)
+ !c #BS WKxy6(i,j)=WKxy6(i,j)+ww
+ !c #BS end do ; end do
+ !c #BS end do
+ !c #BS end do
+ !
+ !
+ !c #BS do j=jp11,my1
+ !c #BS do i=ip11,mx1
+ !c #BS uss_HY(i,j)=WKxy5(i,j)/WKxy6(i,j)
+ !c #BS end do
+ !c #BS end do
+ !end spatial smoothing
+
+ snow_filter = .true.
+ if(snow_filter .and. mod(iterun, 2) == 0) call sno_filtering
+
+#if(BS)
+ do i = 1, mx
+ do j = 1, my
+ ! uss_HY(i,j) = uss_HY(i,j) * 62.5e-3
+ ! snowHY(i,j) = snowHY(i,j) + dt__SV * rolvDY(i,j,mz)*uss_HY(i,j) !BUGBUG
+ weacIB(i, j, 1) = weacIB(i, j, 1) - dt__SV * rolvDY(i, j, mz) * uss_HY(i, j) &
+ * 1000.
+#if(BD)
+ uqTC(i, j, 1) = WKxy3(i, j) * 62.5e-3
+#endif
+ enddo
+ enddo
+#endif
+
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(wx)
+ if(lSV_v1 == 2) write(6, 6012) uss_HY(iSV_v1, jSV_v1) * 1.e3
+6012 format(10x, 'After SISVAT(2): us* [mm/s] =', f9.3)
+#endif
+
+ ! +--Additional OUTPUT for VERIFICATION
+ ! + ----------------------------------
+#if(WR)
+ do j = jp11, my1
+ do i = ip11, mx1
+ if(ifrVER(i, j) /= 100) write(6, 660) isolSL(i, j), i, j, ifrVER(i, j) &
+ ,(ifraTV(i, j, n), n=1, nvx)
+660 format(' WARNING: Mosaic', i2, ' (', 2i4, ') = ', i4, i6, 2i4)
+ enddo
+ enddo
+ i = imez + 10.*111.111e3 / dx
+ j = jmez
+ write(6, 6060) itexpe, jdarGE, labmGE(mmarGE), iyrrGE &
+ , jhurGE, minuGE, GElatr(i, j) / degrad &
+ , tairDY(i, j, mz), virDY(i, j, mz), 1.e3 * rolvDY(i, j, mz) &
+ , hsenSL(i, j), hlatSL(i, j), -86400.0 * SLuqs(i, j) &
+ , 1.e3 * rainHY(i, j), evapTV(i, j), runoTV(i, j)
+6060 format(i6, i3, '-', a3, '-', i4, ':', i2, ':', i2, f6.2, '?N', &
+ f9.3, ' K', f6.3, f6.3, ' kg/m3', 2(f6.1, ' W/m2'), &
+ f6.3, ' mm/day', 3(f9.3, ' mm'))
+#endif
+ ! +--Verification of Vectorization
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+#if(VR)
+ write(6, 6100)
+6100 format(/, 'Verification of Vectorization: Before CALL')
+ do n = mw, 1, -1
+ do j = my, 1, -1
+ write(6, 6110)(ij0ver(i, j, n), i=1, mx)
+6110 format(132i1)
+ enddo
+ write(6, 6103)
+6103 format(1x)
+ enddo
+ write(6, 6101)
+6101 format(/, 'Verification of Vectorization: After CALL')
+ do n = mw, 1, -1
+ do j = my, 1, -1
+ write(6, 6110)(ij_ver(i, j, n), i=1, mx)
+ enddo
+ write(6, 6103)
+ enddo
+ do n = 1, mw
+ do j = 1, my
+ do i = 1, mx
+ if(ijdver(i, j, n) /= 0 .and. ij_ver(i, j, n) /= 1) write(6, 6102) i, j, n, ijdver(i, j, n)
+6102 format(' Vectorization ERROR on', 3i4, ' (', i6, ')')
+ enddo
+ enddo
+ enddo
+#endif
+
+ if(.not. INI_SV) &
+ INI_SV = .true.
+
+ return
+endsubroutine PHY_SISVAT_MP
diff --git a/MAR/code_mar/phymar.f90 b/MAR/code_mar/phymar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8eb9eec11efdeb97af5ef600c8cc8a93ae21e0e9
--- /dev/null
+++ b/MAR/code_mar/phymar.f90
@@ -0,0 +1,96 @@
+subroutine phymar
+ ! +------------------------------------------------------------------------+
+ ! | MAR phymar 07-12-2020 MAR |
+ ! | subroutine phymar is used to define physical constants used in MAR |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use mardim
+ use marphy
+ use mar_ge
+ use radcep
+
+ implicit none
+
+ ! +--LMDZ Time Constants
+ ! + ===================
+ logical YR_360, YR_365 ! y_360
+ character(len=10) CALENDAR
+ integer n
+ integer ioopen, ioread
+
+ ! njyr30: Nb of Days since Begin of the Year, before Current Month
+ integer, parameter :: njyr30(0:12) = &
+ (/0, 0, 30, 60, 90, 120, 150, 180, 210, 240, 270, 300, 330/)
+ ! njyb30: Leap Year Correction to njyrGE
+ integer, parameter :: njyb30(0:12) = &
+ (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
+ ! njmo30: Nb of Days in each Month of the Year
+ integer, parameter :: njmo30(0:12) = &
+ (/0, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30/)
+ ! njmb30: Leap Year Correction to njmo30
+ integer, parameter :: njmb30(0:12) = &
+ (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
+
+ ! njyrGE : Number of Days since Begin of the Year before Current Month
+ njyrGE = (/0, 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334/)
+ ! njybGE : Leap Year Correction to current Day of the Year
+ njybGE = (/0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/)
+ ! njmoGE : Number of Days in each Month of the Year
+ njmoGE = (/0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
+ ! njmbGE : Leap Year Correction to njmoGE
+ njmbGE = (/0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
+
+ YR_360 = .false.
+ YR_365 = .false.
+
+ CMIP_scenario = "ssp370" ! RCP26,RCP45,...,ssp126,ssp245,...
+ open(unit=10, file="MARscenario.ctr", status="old", iostat=ioopen)
+ if(ioopen == 0) then
+ read(10, *, iostat=ioread) CMIP_scenario
+ if(ioread == 0) then
+ print *, "phymar CMIP scenario="//trim(CMIP_scenario)
+ endif
+ read(10, *, iostat=ioread) CALENDAR
+ if(ioread == 0) then
+ if(TRIM(CALENDAR) == "YR_360") YR_360 = .true.
+ if(TRIM(CALENDAR) == "yr_360") YR_360 = .true.
+ if(TRIM(CALENDAR) == "YR_365") YR_365 = .true.
+ if(TRIM(CALENDAR) == "yr_365") YR_365 = .true.
+
+ if(TRIM(CMIP_scenario) == "SSP126") CMIP_scenario = "ssp126"
+ if(TRIM(CMIP_scenario) == "SSP245") CMIP_scenario = "ssp245"
+ if(TRIM(CMIP_scenario) == "SSP370") CMIP_scenario = "ssp370"
+ if(TRIM(CMIP_scenario) == "SSP585") CMIP_scenario = "ssp585"
+ if(TRIM(CMIP_scenario) == "SSP26") CMIP_scenario = "ssp126"
+ if(TRIM(CMIP_scenario) == "SSP45") CMIP_scenario = "ssp245"
+ if(TRIM(CMIP_scenario) == "SSP70") CMIP_scenario = "ssp370"
+ if(TRIM(CMIP_scenario) == "SSP85") CMIP_scenario = "ssp585"
+ endif
+ else
+ print *, "phymar ERROR: MARscenario.ctr no found!!!"
+ endif
+ close(10)
+
+ if(YR_360) then
+ print *, "phymar YR_360=.true."
+ njmoGE = njmo30
+ njmbGE = njmb30
+ njyrGE = njyr30
+ njybGE = njyb30
+ endif
+
+ if(YR_365) then
+ print *, "phymar YR_365=.true."
+ do n = 0, 12
+ njmbGE(n) = 0
+ njybGE(n) = 0
+ enddo
+ endif
+
+ ! +--Time Constant
+ ! + -------------
+ ! nhyrGE : Number of Hours in one Year
+ nhyrGE = (njyrGE(12) + njmoGE(12)) * 24
+
+ return
+endsubroutine phymar
diff --git a/MAR/code_mar/phyrad_cep.f90 b/MAR/code_mar/phyrad_cep.f90
new file mode 100644
index 0000000000000000000000000000000000000000..44813f435824fe13be63a29120304d22161cb4ec
--- /dev/null
+++ b/MAR/code_mar/phyrad_cep.f90
@@ -0,0 +1,696 @@
+#include "MAR_pp.def"
+subroutine PHYrad_CEP_mp(dST_UA)
+
+ ! +------------------------------------------------------------------------+
+ ! | MAR PHYSICS XF 07-12-2020 MAR |
+ ! | |
+ ! | subroutine PHYrad_CEP interfaces MAR with the new |
+ ! | ECMWF Solar/Infrared Radiative Transfer Scheme |
+ ! | |
+ ! | f77 / f90 MAR /ECMWF Interface |
+ ! | |
+ ! | ECMWF Code Source: J.-J. Morcrette, 28 nov 2002 |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_hy
+ use mar_ra
+ use mar_sl
+ use mar_wk
+ use mar_io
+#if(AR)
+ use mar_tc
+#endif
+ ! +--Interface Variables
+ ! + ====================
+ use radcep
+
+ implicit none
+
+ integer i, j, k, m
+ real dST_UA ! Distance Soleil-Terre [UA]
+ !real RAcldE(mx, my, mz) ! Cloud Emissivity [-]
+ !real htngIR(mx, my, mz) ! IR Heating [K/s]
+ !real htngSO(mx, my, mz) ! Solar Heating [K/s]
+
+ ! +--INPUT
+ ! + -----
+
+ logical PHYrad_CEP_ERR
+
+ integer yymmdd ! Date in the form yyyyMMdd
+ integer i_hhss ! Number of seconds in the day
+
+ real AlbCEP(klonr) ! Surface Albedo
+ real pa_CEP(klonr, klevr) ! Air Pressure (layer)
+ real pahCEP(klonr, klevr + 1) ! Air Pressure (layer interface)
+ real fcdCEP(klonr, klevr) ! Cloud Fraction (dropplets)
+ real emsCEP(klonr) ! Surface IR Emissivity
+ real lsmCEP(klonr) ! Land/Sea Mask: (1.=land 0.=ocean)
+ real cszCEP(klonr) ! cosine (solar zenithal Distance)
+ real czeMIN ! Minimum accepted for cszCEP
+ real larCEP(klonr) ! Latitude [radian]
+ real lorCEP(klonr) ! Longitude [radian]
+ real ta_CEP(klonr, klevr) ! Air Temperature
+ real tasCEP(klonr) ! Surface Temperature
+
+ real AerCEP(klonr, nn_aer, klevr) ! Aerosol Concentration !
+ real O3rCEP(klonr, klevr) ! O3 Concentration
+
+ real cldMAX(mx, my) ! Cloud Max Fraction [-]
+ real CD_OD1(klonr, klevr) ! Cloud Optical Depth [-]
+ real CDtOD1(klonr) ! Cloud Optical Depth [-]
+ ! ! (vertically integrated)
+ real Ae_ODa(klonr, klevr) ! Aeros.Optical Depth [-]
+ real AetODa(klonr) ! Aeros.Optical Depth [-]
+ ! ! (vertically integrated)
+ real qv_CEP(klonr, klevr) ! Vapor Concentr. [kg/kg]
+ real qi_CEP(klonr, klevr) ! Cryst. Concentr. [kg/kg]
+ real qw_CEP(klonr, klevr) ! Droppl. Concentr. [kg/kg]
+ real sw_CEP(klonr, klevr) ! Saturation % water [kg/kg]
+ real qr_CEP(klonr, klevr) ! Drops Concentr. [kg/kg]
+ integer n, l, nae
+ real ww, nn, ss
+
+ ! +--OUTPUT
+ ! + ------
+
+ real FIRn_c(klonr, klevr + 1) ! CLEAR-SKY LW NET FLUXES
+ real FIRn_t(klonr, klevr + 1) ! TOTAL LW NET FLUXES
+ real FSOn_c(klonr, klevr + 1) ! CLEAR-SKY SW NET FLUXES
+ real FSOn_t(klonr, klevr + 1) ! TOTAL SW NET FLUXES
+ real FSOs_t(klonr) ! TOTAL-SKY SURFACE SW DOWNWARD FLUX
+
+ integer ij0MAX, ij_MAX, OMP_GET_THREAD_NUM
+ parameter(ij0MAX=mx2 * my2)
+ integer nbvMAX, nb_MAX
+ parameter(nbvMAX=ij0max / klonr)
+ integer klonrb
+ parameter(klonrb=ij0max - klonr * nbvMAX)
+
+ integer ikl, lkl, nkl
+ integer ij, nnn, nvc
+ integer k2i(klonr) ! i index corresp. to kl
+ integer k2j(klonr) ! j index corresp. to kl
+#if(VR)
+ integer ij0ver(mx, my) ! For Verif. of Vectoriz.
+ integer ij_ver(mx, my) ! For Verif. of Vectoriz.
+ integer ij2, ijdver(mx, my) ! For Verif. of Vectoriz.
+#endif
+
+ ! +--Surface Albedo
+ ! + --------------
+
+ real bsegal, albmax, albx, dalb, albu
+ real czeMAX, czrx
+ real siceOK, ciceOK, zangOK, sign_T, ColdOK
+ real sign_S, snowOK
+
+ real qsfac
+
+ ! +--OUTPUT
+ ! + ------
+
+ integer io, CEPerr(mx, my)
+ real zlevel, pr_atm, qcloud, fcloud, tmp
+ real heatng ! Total Heating [K/s]
+
+ ! +--DATA
+ ! + ====
+
+#if(GR)
+ ! qsfac : qs_HY contribution to qi_cep
+ data qsfac/1.0/
+#elif(AC)
+ ! qsfac for Antarctica
+ data qsfac/0.3/
+#else
+ data qsfac/0.5/
+#endif
+ data bsegal/2.00e0/
+ data albmax/0.99e0/
+ ! czeMAX: 80.deg (Segal et al., 1991 JAS)
+ data czeMAX/0.173648178/
+ ! MIN (Solar Zenithal Distance)
+ data czeMIN/5.00e-6/
+
+ ! +--INITIALIZATION
+ ! + ==============
+
+#if(DB)
+ open(unit=30, status='unknown', file='PHYrad_CEP.txt')
+ rewind 30
+#endif
+
+ if(iterun == 0) then
+ ij_MAX = mx2 * my2
+ if(mod(ij_MAX, klonr) == 0) then
+ nb_MAX = ij_MAX / klonr
+ else
+ nb_MAX = ij_MAX / klonr + 1
+ endif
+ endif
+
+ qcloud = 0.
+ fcloud = 0.
+
+ ! +--Time & Insolation (top of the atmosphere)
+ ! + =========================================
+
+ yymmdd = min(iyrrGE, 2004) * 10000 + mmarGE * 100 + jdarGE
+ i_hhss = jhurGE * 3600 + minuGE * 60 + jsecGE
+
+ ! +--Zenith Angle Correction of Snow Albedo
+ ! + ======================================
+
+ if(mod(iterun, jtRadi) == 0) then ! CTR
+ if(.not. VSISVAT) then ! CTR
+
+ do j = jp11, my1
+ do i = ip11, mx1
+
+ siceOK = 1 - min(iabs(isolSL(i, j) - 2), iun)
+ ciceOK = 1 - min(iabs(isolSL(i, j) - 3), iun)
+
+ zangOK = max(siceOK, ciceOK)
+
+ sign_T = sign(unun, TfSnow - TairSL(i, j))
+ ColdOK = max(zero, sign_T)
+ zangOK = max(zangOK, ColdOK)
+
+ sign_S = zero
+ snowOK = max(zero, sign_S)
+ zangOK = max(zangOK, snowOK)
+
+#if(CP)
+ zangOK = 0.0e+0
+#endif
+
+ ! +--Snow and/or ice covered surface
+ ! + -------------------------------
+
+ albx = alb0SL(i, j)
+ czrx = max(czeMAX, czenGE(i, j))
+ dalb = 0.32e0 * ((bsegal + unun) / (unun + 2.e0 * bsegal * czrx) &
+ - unun) / bsegal
+ dalb = max(dalb, zero)
+ albx = dalb + alb0SL(i, j)
+ albx = min(albx, albmax)
+ ! +*** Influence of Sun Zenith Angle
+ ! + (Segal et al., 1991 JAS 48, p.1025)
+
+ ! +--Underlying Surface Albedo
+ ! + -------------------------
+
+ albu = alb0SL(i, j)
+
+ ! +--Actual Albedo
+ ! + -------------
+
+ albeSL(i, j) = zangOK * albx + (1 - zangOK) * albu
+
+ enddo
+ enddo
+
+ ENDif ! CTR
+
+ ! +--Effective Radiating Surface Temperature
+ ! + =======================================
+
+ write(6, 397) jdarGE, mmarGE, iyrrGE, jhurGE, minuGE, jsecGE
+
+397 format(' Call of PHYrad_CEP_mp IN : ' &
+ , i2, '/', i2, '/', i4, ' ', i2, ':', i2, ':', i2)
+
+ !$OMP PARALLEL
+ RADin2 = .false.
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL do &
+ !$OMP firstprivate(AlbCEP,pa_CEP,pahCEP,fcdCEP, &
+ !$OMP emsCEP,lsmCEP,cszCEP,larCEP,lorCEP, &
+ !$OMP AerCEP,O3rCEP,qv_CEP,qi_CEP,qw_CEP, &
+ !$OMP sw_CEP,qr_CEP,ta_CEP,tasCEP,k2i,k2j, &
+ !$OMP FIRn_c,FIRn_t,FSOn_c,FSOn_t,FSOs_t,tmp,n, &
+ !$OMP CD_OD1,CDtOD1,Ae_ODa,AetODa,i,lkl,ikl,nae)
+ do j = jp11, my1
+ do i = ip11, mx1
+
+ WKxy1(i, j) = 0.0
+
+ do n = 1, mw
+ WKxy1(i, j) = WKxy1(i, j) + &
+ eps0SL(i, j) * SLsrfl(i, j, n) * &
+ tsrfSL(i, j, n)**4.
+ enddo
+
+ tviRA(i, j) = sqrt(sqrt(WKxy1(i, j) &
+ + (1.-eps0SL(i, j)) * RAd_ir(i, j) / stefan))
+ cld_SL(i, j) = 0.
+ cldMAX(i, j) = 0.
+ CEPerr(i, j) = 0
+#if(VR)
+ ij0ver(i, j) = 0
+ ij_ver(i, j) = 0
+ ijdver(i, j) = 0
+#endif
+
+ ! +--Solar and IR Transfer through the Atmosphere
+ ! + ============================================
+
+ ! +--Grid Point Dependant Variables --> PHYrad_CEP "Vector"Variables
+ ! + ------------------------------------------------------------------
+
+ do ikl = 1, klonr
+ k2i(ikl) = i
+ k2j(ikl) = j
+#if(VR)
+ ij0ver(i, j) = ij0ver(i, j) + 1
+ ijdver(i, j) = ijdver(i, j) + ij
+#endif
+
+ ! +--Geographic Coordinates
+ ! + ^^^^^^^^^^^^^^^^^^^^^^
+ larCEP(ikl) = sign(1., GElatr(i, j)) * &
+ min(89.9 * degrad, abs(GElatr(i, j)))
+ lorCEP(ikl) = GElonh(i, j) * hourad
+ lorCEP(ikl) = lorCEP(ikl) &
+ - pi * 2.*min(sign(1., lorCEP(ikl)), 0.)
+
+ ! +--Albedo
+ ! + ^^^^^^
+ AlbCEP(ikl) = albeSL(i, j)
+
+ ! +--Surface
+ ! + ^^^^^^^
+ pahCEP(ikl, mzz) = (pstDY(i, j) * sigmid(mzz) + ptopDY) * 1.e3
+
+ emsCEP(ikl) = eps0SL(i, j) ! Emissivity
+ lsmCEP(ikl) = 1 - maskSL(i, j) ! Land/sea Mask
+ cszCEP(ikl) = max(czenGE(i, j), czeMIN) ! cos(zenith.Dist.)
+
+ tasCEP(ikl) = tairSL(i, j)
+
+ enddo
+
+ do lkl = 1, mz
+ do ikl = 1, klonr
+ ! +--Pressure
+ ! + ^^^^^^^^
+ pahCEP(ikl, lkl) = (pstDY(i, j) * sigmid(lkl) + ptopDY) * 1.e3
+ pa_CEP(ikl, lkl) = (pstDY(i, j) * sigma(lkl) + ptopDY) * 1.e3
+
+ ! +--Temperature
+ ! + ^^^^^^^^^^^
+ ta_CEP(ikl, lkl) = tairDY(i, j, lkl)
+
+ ! +--Water Concentration (qsHY: Von Walden et al. 2003, JAM 42, p.1400)
+ ! + ^^^^^^^^^^^^^^^^^^^^^ ( Fall snow 24 mim )
+ ! ( Blown snow 11 mim, only over ice sheet)
+ ! Vapor
+ qv_CEP(ikl, lkl) = max(1.e-6, qvDY(i, j, lkl))
+ ! Crystals
+ qi_CEP(ikl, lkl) = 0.
+ ! XF qi_CEP : exp((tairDY(i, j, lkl)-273.15)
+ qi_CEP(ikl, lkl) = qiHY(i, j, lkl) &
+ + (1.-min(1., exp((tairDY(i, j, lkl) - 273.15) * 0.1))) &
+ * (qsHY(i, j, lkl) * qsfac)
+ ! Dropplets
+ qw_CEP(ikl, lkl) = 0.
+ qw_CEP(ikl, lkl) = qwHY(i, j, lkl)
+ ! Saturation % W
+ sw_CEP(ikl, lkl) = min(qvswDY(i, j, lkl), 0.03)
+ ! Rain Drops
+ qr_CEP(ikl, lkl) = 0.
+ qr_CEP(ikl, lkl) = qrHY(i, j, lkl)
+
+ if(gplvDY(i, j, lkl) * grvinv - sh(i, j) > 50.) then
+#if(GR)
+ qi_CEP(ikl, lkl) = qiHY(i, j, lkl) + 0.80 * qsHY(i, j, lkl)
+#endif
+
+#if(EU)
+ qi_CEP(ikl, lkl) = qiHY(i, j, lkl) + qsHY(i, j, lkl)
+ ! qw_CEP(ikl,lkl) = qw_CEP(ikl,lkl) * 1.15
+ ! qr_CEP(ikl,lkl) = qr_CEP(ikl,lkl) * 1.15
+ ! qi_CEP(ikl,lkl) = qi_CEP(ikl,lkl) * 1.1
+ ! qv_CEP(ikl,lkl) = qv_CEP(ikl,lkl) * 1.05
+#endif
+ endif
+
+ !C #EU ... * 1.15 instead
+
+ ! +--Cloud Fraction (liquid water)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ fcdCEP(ikl, lkl) = cfraHY(i, j, lkl)
+
+ ! +--O3 Concentration
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ O3rCEP(ikl, lkl) = O3_MAR(i, j, lkl)
+
+ enddo
+ enddo
+
+ ! +--Aerosol Concentration
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ do nae = 1, nn_aer
+ do lkl = 1, mz
+ do ikl = 1, klonr
+ AerCEP(ikl, nae, lkl) &
+ = Ae_MAR(k2i(ikl), k2j(ikl), nae, lkl)
+ enddo
+ enddo
+ enddo
+
+ ! +--Radiative Transfert Computation
+ ! + -------------------------------
+
+ ! + **********
+ call PHYrad2CEP(klonr, klevr, nn_aer, yymmdd, i_hhss &
+ , dST_UA, AlbCEP, pa_CEP, pahCEP, fcdCEP &
+ , emsCEP, lsmCEP, cszCEP, larCEP, lorCEP &
+ , AerCEP, O3rCEP, qv_CEP, qi_CEP, qw_CEP &
+ , sw_CEP, qr_CEP, ta_CEP, tasCEP &
+ , FIRn_c, FIRn_t, FSOn_c, FSOn_t, FSOs_t &
+ , CD_OD1, CDtOD1, Ae_ODa, AetODa, iyrrGE &
+ , radINI, radIN2, CMIP_scenario)
+ ! + **********
+
+ ! + -------------------------------
+
+ RADini = .true.; RADin2 = .true.
+
+ ! +--Grid Point Dependant Variables <-- PHYrad_CEP "Vector"Variables
+ ! + ------------------------------------------------------------------
+
+ do ikl = 1, klonr
+
+#if(VR)
+ ij2 = ij2 + 1
+ ijdver(i, j) = ijdver(i, j) - ij2
+ ij_ver(i, j) = ij_ver(i, j) + 1
+#endif
+
+ ! +--Surface Cloud/Aerosol Optical Depth
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(.not. isnan(CDtOD1(ikl))) &
+ RAcdtO(i, j) = CDtOD1(ikl)
+ if(.not. isnan(AetODa(ikl))) &
+ RAertO(i, j) = AetODa(ikl)
+
+ ! +--Surface Downward Radiative Fluxes
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(.not. isnan(FIRn_t(ikl, 1))) &
+ RAdOLR(i, j) = -FIRn_t(ikl, 1)
+
+ if(.not. isnan(FSOs_t(ikl)) .and. FSOs_t(ikl) < 1350) then
+ if(FSOs_t(ikl) < 0.1) FSOs_t(ikl) = 0.
+ RAdsol(i, j) = FSOs_t(ikl)
+ sol_SL(i, j) = FSOs_t(ikl) * (1.-albeSL(i, j))
+ else
+ CEPerr(i, j) = CEPerr(i, j) + 1
+ endif
+
+ if(.not. isnan(FSOn_t(ikl, 1))) &
+ RAdOSR(i, j) = -FSOn_t(ikl, 1)
+
+ if(.not. isnan(FIRn_t(ikl, 1 + klevr))) then
+ RAd_ir(i, j) = FIRn_t(ikl, 1 + klevr) &
+ + eps0SL(i, j) * TairSL(i, j) * TairSL(i, j) &
+ * TairSL(i, j) * TairSL(i, j) &
+ * 5.670373e-8
+#if(EU)
+ !XF 04/12/2020
+ RAd_ir(i, j) = RAd_ir(i, j) + 1.
+#endif
+#if(GR)
+ !XF 04/12/2020
+ RAd_ir(i, j) = RAd_ir(i, j) + 1.
+#endif
+
+#if(EU)
+ if(sol_SL(i, j) > 0) then
+ tmp = RAd_ir(i, j) * 0.03
+ RAd_ir(i, j) = RAd_ir(i, j) * 1.03
+ RAdsol(i, j) = max(RAdsol(i, j) * 0.90, RAdsol(i, j) - tmp * 3.)
+ sol_SL(i, j) = RAdsol(i, j) * (1.-albeSL(i, j))
+ endif
+#endif
+ else
+ CEPerr(i, j) = CEPerr(i, j) + 1
+ endif
+
+ ! +--Surface IR Net Radiative Fluxes
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(.not. isnan(FIRn_t(ikl, mzz))) &
+ RAfnIR(i, j, mzz) = FIRn_t(ikl, mzz)
+ if(.not. isnan(FIRn_c(ikl, mzz))) &
+ RAfncIR(i, j, mzz) = FIRn_c(ikl, mzz)
+ enddo
+
+ do lkl = 1, mz
+ do ikl = 1, klonr
+
+ ! +--Atmosph. Net Radiative Fluxes
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(.not. isnan(FIRn_t(ikl, lkl))) &
+ RAfnIR(i, j, lkl) = FIRn_t(ikl, lkl)
+ if(.not. isnan(FSOn_t(ikl, lkl))) &
+ RAfnSO(i, j, lkl) = FSOn_t(ikl, lkl)
+ if(.not. isnan(FIRn_c(ikl, lkl))) &
+ RAfncIR(i, j, lkl) = FIRn_c(ikl, lkl)
+ if(.not. isnan(FSOn_c(ikl, lkl))) &
+ RAfncSO(i, j, lkl) = FSOn_c(ikl, lkl)
+
+ ! +--Cloud Fraction
+ ! + ^^^^^^^^^^^^^^^^
+ if(.not. isnan(fcdCEP(ikl, lkl))) then
+ cldMAX(i, j) = max(fcdCEP(ikl, lkl), cldMAX(i, j))
+ CldFRA(i, j, lkl) = fcdCEP(ikl, lkl)
+ endif
+
+ ! +--Atmosph.Cloud/Aerosol Optical Depth
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(.not. isnan(CD_OD1(ikl, lkl))) &
+ RAcd_O(i, j, lkl) = CD_OD1(ikl, lkl)
+ if(.not. isnan(Ae_ODa(ikl, lkl))) &
+ RAer_O(i, j, lkl) = Ae_ODa(ikl, lkl)
+
+ ! +--Radiative Heating
+ ! + ^^^^^^^^^^^^^^^^^
+ WKxyz1(i, j, lkl) = -(FIRn_t(ikl, lkl + 1) - FIRn_t(ikl, lkl)) &
+ * gravit / (cp * 1.e3 * pstDY(i, j) * dsigm1(lkl))
+ WKxyz2(i, j, lkl) = -(FSOn_t(ikl, lkl + 1) - FSOn_t(ikl, lkl)) &
+ * gravit / (cp * 1.e3 * pstDY(i, j) * dsigm1(lkl))
+
+ ! +--O3 Concentration
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ if(.not. isnan(O3rCEP(ikl, lkl))) &
+ O3_MAR(i, j, lkl) = O3rCEP(ikl, lkl)
+
+ enddo
+ enddo
+
+ ! +--Cloud Fraction
+ ! + ^^^^^^^^^^^^^^^^
+ do ikl = 1, klonr
+
+ cld_SL(i, j) = cldMAX(i, j)
+ clduSL(i, j) = 0.
+ cldmSL(i, j) = 0.
+ clddSL(i, j) = 0.
+ do lkl = 1, mz
+ if(pahCEP(ikl, lkl) < 44000) &
+ clduSL(i, j) = max(clduSL(i, j), CldFRA(i, j, lkl))
+ if(pahCEP(ikl, lkl) >= 44000 .and. pahCEP(ikl, lkl) <= 68000) &
+ cldmSL(i, j) = max(cldmSL(i, j), CldFRA(i, j, lkl))
+ if(pahCEP(ikl, lkl) > 68000) &
+ clddSL(i, j) = max(clddSL(i, j), CldFRA(i, j, lkl))
+ enddo
+ enddo
+
+ ! +--Radiative Heating
+ ! + ^^^^^^^^^^^^^^^^^
+ do lkl = 1, mz
+ do ikl = 1, klonr
+ tmp = (WKxyz1(i, j, lkl) + WKxyz2(i, j, lkl)) &
+ * dt / pkDY(i, j, lkl)
+
+ if(.not. isnan(tmp) .and. abs(tmp) < 10) then
+ pktRAd(i, j, lkl) = tmp
+ !htngIR(i, j, lkl) = WKxyz1(i, j, lkl) * 86400.
+ !htngSO(i, j, lkl) = WKxyz2(i, j, lkl) * 86400.
+ else
+ CEPerr(i, j) = CEPerr(i, j) + 1
+ endif
+ enddo
+ enddo
+
+ ! +--Aerosol Concentration
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ do nae = 1, nn_aer
+ do lkl = 1, mz
+ do ikl = 1, klonr
+ if(.not. isnan(AerCEP(ikl, nae, lkl))) &
+ Ae_MAR(k2i(ikl), k2j(ikl), nae, lkl) &
+ = AerCEP(ikl, nae, lkl)
+ enddo
+ enddo
+ enddo
+
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ write(6, 398) jdarGE, mmarGE, iyrrGE, jhurGE, minuGE, jsecGE
+
+398 format(' Call of PHYrad_CEP_mp OUT : ' &
+ , i2, '/', i2, '/', i4, ' ', i2, ':', i2, ':', i2)
+
+ ! +--Lateral Boundary Conditions for Radiative Variables
+ ! + ===================================================
+
+ do k = 1, mz
+ do j = 1, my
+ pktRAd(1, j, k) = pktRAd(ip11, j, k)
+ pktRAd(mx, j, k) = pktRAd(mx1, j, k)
+ enddo
+ do i = 1, mx
+ pktRAd(i, 1, k) = pktRAd(i, jp11, k)
+ pktRAd(i, my, k) = pktRAd(i, my1, k)
+ enddo
+ enddo
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.
+ WKxyz2(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ ! ------------------------------------------------------------
+
+ PHYrad_CEP_ERR = .false.
+
+ do j = 4, my - 3
+ do i = 4, mx - 3
+ if(CEPerr(i, j) > 0) then
+ write(6, 399) iyrrGE, mmarGE, jdarGE, &
+ jhurGE, i, j, CEPerr(i, j)
+399 format('XF WARNING: PHYrad_CEP_mp NaN on ', i4, '/', i2, '/', &
+ i2, i3, 'h, (i,j)=', i4, i4, ', #err=', i4)
+ PHYrad_CEP_ERR = .true.
+ endif
+
+ ww = 0; nn = 0; ss = 0
+
+ do k = -1, 1
+ do l = -1, 1
+ ww = 1
+ if(k == 0 .or. l == 0) ww = 2
+ if(k == 0 .and. l == 0) ww = 0
+ if(RAdsol(i + k, j + l) < 100) ww = 0
+ nn = nn + ww
+ ss = ss + RAdsol(i + k, j + l) * ww
+ enddo
+ enddo
+
+ if(nn == 12 .and. RAdsol(i, j) < (ss / nn) * 0.10) then
+ write(6, 400) iyrrGE, mmarGE, jdarGE, &
+ jhurGE, i, j
+400 format('ERROR: likely error of // in PHYrad_CEP_mp on', &
+ i4, '/', i2, '/', i2, i3, 'h, (i,j)=', i4, i4)
+ RAdsol(i, j) = ss / nn
+ print *, "CHECK your SWD output!!!!"
+ endif
+ enddo
+
+ ss = 0; ww = 0
+
+ do i = 4, mx - 3
+ ss = ss + RAdsol(i, j + 0)
+ ww = ww + RAdsol(i, j + 1)
+ enddo
+ ss = ss / real(mx - 3 - 4 + 1)
+ ww = ww / real(mx - 3 - 4 + 1)
+
+ if((ss < 1 .and. ww > 100) .or. (ss > 100 .and. ww < 1)) then
+ write(6, 400) iyrrGE, mmarGE, jdarGE, jhurGE, 0, j
+ print *, "CHECK your SWD output!!!!"
+ stop
+ endif
+
+ enddo
+
+ ! ------------------------------------------------------------
+
+ do j = 2, my - 1
+ do i = 2, mx - 1
+ do n = 1, mz
+
+ ww = 0; nn = 0; ss = 0
+
+ do k = -1, 1
+ do l = -1, 1
+ ww = 1
+ if(k == 0 .or. l == 0) ww = 2
+ if(k == 0 .and. l == 0) ww = 0
+ nn = nn + ww
+ ss = ss + abs(pktRAd(i + k, j + l, n)) * ww
+ enddo
+ enddo
+
+ if(abs(pktRAd(i, j, n)) > (ss / nn) + 1.5 &
+ .or. abs(pktRAd(i, j, n)) > 3.+2.*n / mz) then
+ write(6, 390) iyrrGE, mmarGE, jdarGE, jhurGE, i, j, n
+390 format('ERROR: likely error of pktRAd in PHYrad_CEP_mp on', &
+ i4, '/', i2, '/', i2, i3, 'h, (i,j)=', i4, i4, i4)
+ pktRAd(i, j, n) = sign(1., pktRAd(i, j, n)) * (ss / nn)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! ------------------------------------------------------------
+
+ ! C +--OUTPUT for Verification
+ ! C + -----------------------
+
+#if(VR)
+ write(6, 6000)
+6000 format(/, 'Verification of Vectorization: Before CALL')
+ do j = my, 1, -1
+ write(6, 6010)(ij0ver(i, j), i=1, mx)
+6010 format(132i1)
+ enddo
+
+ write(6, 6001)
+6001 format(/, 'Verification of Vectorization: After CALL')
+ do j = my, 1, -1
+ write(6, 6010)(ij_ver(i, j), i=1, mx)
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ if(ijdver(i, j) /= 0 .and. ij_ver(i, j) /= 1) write(6, 6002) i, j, ijdver(i, j)
+6002 format(' Vectorization ERROR on', 2i4, ' (', i6, ')')
+ enddo
+ enddo
+#endif
+
+ endif
+
+#if(DB)
+ close(unit=30)
+#endif
+
+ return
+endsubroutine PHYrad_CEP_mp
diff --git a/MAR/code_mar/phyrad_top.f90 b/MAR/code_mar/phyrad_top.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c4c9725ecbe9abb0afcf148fab7dc836d8ef5f05
--- /dev/null
+++ b/MAR/code_mar/phyrad_top.f90
@@ -0,0 +1,527 @@
+#include "MAR_pp.def"
+subroutine PHYrad_top(Dis_ST)
+ ! +------------------------------------------------------------------------+
+ ! | MAR PHYSICS (INSOL) 15-11-2007 MAR |
+ ! | subroutine PHYrad_top computes |
+ ! | Time Insolation at the Top of the Atmosphere |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | REFER.: Ch. Tricot, personal communication |
+ ! | ^^^^^^^ M.F. Loutre, personal communication and thesis (1993) |
+ ! | |
+ ! | INPUT : mmarGE, jdarGE: Month and Day of the Year |
+ ! | ^^^^^^^ jhurGE, minuGE, jsecGE: Hour, Minute, and Second |
+ ! | GElat0, GElon0: Latitude, Longitude |
+ ! | GElatr(mx,my) : Latitude (radians) |
+ ! | GElonh(mx,my) : Longitude (hours) |
+ ! | itizGE(mx,my) : Time Zone |
+ ! | |
+ ! | OUTPUT: rsunGE : Insolation normal to Atmosphere Top (W/m2) |
+ ! | ^^^^^^^ czenGE(mx,my) : Cosinus of the Zenithal Distance |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use marsnd
+ use mar_wk
+ use mar_io
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ real Dis_ST
+
+ ! +--LOCAL VARIABLES
+ ! + ===============
+
+ integer i, j, k, m
+ real pirr, xl, so
+ real xllp, xee, xse
+ real xlam, dlamm, anm, ranm, ranv, anv, tls
+ real Tyear, step, rlam, sd, cd, deltar, delta
+
+ real ddt, arg, et, argc, ahc
+ real c1, c2, c3, s1, s2, s3
+ real timdl, timh, ahor, ahorr, RadLat, chor, zenitr
+ integer nj, lhc
+
+ real omesun
+#if(AZ)
+ real slopx, slopy, omenor
+ real comes, somes, omeswr, anormr, omenwr
+ integer momask
+#endif
+
+#if(MM)
+ real dxdx, azim_0, azim_1, azimdd, azimut, r_azim
+ real azimxx, azimxa, azimxs, azimyy, azimya, azimys
+ real ddxx_2, ddyy_2, ddxy_2, ddzz, tmnt_2, cmnt
+ integer k_azim, nax, nal, na, na2, ka
+ integer i_azim, j_azim, j_azmn, j_azmx, i_azmn, i_azmx, nocoun
+ integer knazim, ni1, ni2, nj1, nj2
+ integer i1, i2, j1, j2, ni
+#endif
+
+ real om, ecc, perh, xob
+
+ ! +--DATA
+ ! + ====
+
+ data om/0.0172142d0/
+
+ ! +--Present Day Insolation
+ ! + ----------------------
+ ! Eccentricity
+ data ecc/0.01673/
+ ! Longitude of the Perihelion (degrees)
+ data perh/102.4/
+ ! Obliquity (degrees)
+ data xob/23.445/
+
+#if(k6)
+ ! +--6 kBP Insolation
+ ! + ----------------
+ ! Eccentricity
+ data ecc/0.018682/
+ ! Longitude of the Perihelion (degrees)
+ data perh/0.87/
+ ! Obliquity (degrees)
+ data xob/24.105/
+#endif
+
+#if(k10)
+ ! +--10 kBPInsolation
+ ! + ----------------
+ ! Eccentricity
+ data ecc/0.019419/
+ ! Longitude of the Perihelion (degrees)
+ data perh/294.81/
+ ! Obliquity (degrees)
+ data xob/24.226/
+#endif
+
+ ! +--Insolation at the Top of the Atmosphere (TIME PARAMETERS)
+ ! + ===============================================================
+
+ ! +--Solar declination : delta
+ ! + -------------------------
+
+ nj = jdarGE + njyrGE(mmarGE)
+ Tyear = 365.25d0
+ step = 360.0d0 / Tyear
+
+ pirr = degrad / 3600.0
+ xl = perh + 180.0
+ so = sin(xob * degrad)
+ ! +...so : sinus of obliquity
+
+ xllp = xl * degrad
+ xee = ecc * ecc
+ xse = sqrt(1.0d0 - xee)
+ xlam = (ecc / 2.0 + ecc * xee / 8.0d0) * (1.0 + xse) * sin(xllp) - xee / 4.0 * &
+ (0.5 + xse) * sin(2.0 * xllp) + ecc * xee / 8.0 * (1.0 / 3.0 + xse) * &
+ sin(3.0 * xllp)
+ xlam = 2.0d0 * xlam / degrad
+ dlamm = xlam + (nj - 80) * step
+ ! +...xlam : true long. sun for mean long. = 0
+ ! +...dlamm : mean long. sun for ma-ja
+ anm = dlamm - xl
+ ranm = anm * degrad
+ xee = xee * ecc
+ ranv = ranm + (2.0 * ecc - xee / 4.0) * sin(ranm) + 5.0 / 4.0 * ecc * ecc * &
+ sin(2.0 * ranm) + 13.0 / 12.0 * xee * sin(3.0 * ranm)
+ anv = ranv / degrad
+ tls = anv + xl
+ rlam = tls * degrad
+ ! +...tls : longitude vraie (degrees)
+ ! +...rlam : longitude vraie (radian)
+ ! +...anv : anomalie vraie (degrees)
+ ! +...ranv : anomalie vraie (radian)
+
+ sd = so * sin(rlam)
+ cd = sqrt(1.0d0 - sd * sd)
+ ! +...sd and cd: cosinus and sinus of solar declination angle (delta)
+ ! +...sinus delta = sin (obl)*sin(lambda) with lambda = real longitude
+ ! +...(Phd. thesis of Marie-France Loutre, ASTR-UCL, Belgium, 1993)
+
+ deltar = atan(sd / cd)
+ delta = deltar / degrad
+ ! +...delta: Solar Declination (degrees, angle sun at equator)
+
+ ! +--Eccentricity Effect
+ ! + -------------------
+
+ Dis_ST = (1.0 - ecc * ecc) / (1.0 + ecc * cos(ranv))
+ ddt = 1.0 / Dis_ST
+ ! +...ddt : 1 / normalized earth's sun distance
+
+ ! +--Insolation normal to the atmosphere (W/m2)
+ ! + ------------------------------------------
+
+ !XF
+ rsunGE = ddt * ddt * 1360.8d0
+
+ ! +--Time Equation (Should maybe be modified in case other than present
+ ! + ------------- conditions are used, minor impact)
+
+ arg = om * nj
+ c1 = cos(arg)
+ c2 = cos(2.d0 * arg)
+ c3 = cos(3.d0 * arg)
+ s1 = sin(arg)
+ s2 = sin(2.d0 * arg)
+ s3 = sin(3.d0 * arg)
+
+ et = 0.0072d0 * c1 - 0.0528d0 * c2 - 0.0012d0 * c3 &
+ - 0.1229d0 * s1 - 0.1565d0 * s2 - 0.0041d0 * s3
+ ! +...et (hour)
+ ! + = difference between true solar and mean solar hour angles.
+ ! + (connected to the earth orbital rotation speed)
+
+ ! +--Insolation at the Top of the Troposphere (Auxiliary Variables)
+ ! + ==============================================================
+
+ ! +--Day Length, Time Sunrise and Sunset at Sounding Grid Point (iSND, jSND)
+ ! + -----------------------------------------------------------------------
+
+ i = iSND
+ j = jSND
+
+ argc = -tan(GElatr(i, j)) * tan(deltar)
+ if(abs(argc) > 1.d0) then
+ ahc = 0.d0
+ if(argc > 1.d0) then
+ lhc = -1
+ timdl = 00.d0
+ ! +... Polar Night
+ else
+ lhc = 1
+ timdl = 24.d0
+ ! +... Midnight Sun
+ endif
+ tlsrGE = 00.d0
+ tlssGE = 00.d0
+ else
+ ahc = acos(argc)
+ lhc = 0
+
+ if(ahc < 0.d0) ahc = -ahc
+ ahc = ahc / hourad
+ timdl = ahc * 2.d0
+ tlsrGE = 12.d0 - ahc + itizGE(i, j) - et - GElonh(i, j)
+ tlssGE = tlsrGE + timdl
+ endif
+
+ tl__GE = jhurGE + minuGE / 60.d0 - itizGE(i, j)
+
+ ! +--Time Angle
+ ! + ----------
+
+ do j = 1, my
+ do i = 1, mx
+ timh = jhurGE + minuGE / 60.d0
+ ahor = timh + GElonh(i, j) - 12.d0 - et
+ ! +... ahor : time angle (hours)
+
+ ahorr = ahor * hourad
+ ! +... ahorr : time angle (radians)
+
+ chor = cos(ahorr)
+
+ ! +--Solar Zenithal Distance zenitr (radians) and
+ ! + Insolation (W/m2) at the Atmosphere Top ===
+ ! + =======================================
+
+ czenGE(i, j) = slatGE(i, j) * sd &
+ + clatGE(i, j) * cd * chor
+ czenGE(i, j) = max(czenGE(i, j), zero)
+
+ cverGE(i, j) = czenGE(i, j)
+
+ ! +--Slope Impact
+ ! + ------------
+
+#if(AZ)
+ zenitr = acos(czenGE(i, j))
+ WKxy3(i, j) = sin(zenitr)
+ WKxy4(i, j) = sin(ahorr)
+#endif
+ enddo
+ enddo
+
+#if(AZ)
+ ! +--Slope Azimuth
+ ! + ~~~~~~~~~~~~~
+ if(iterun <= 1) then
+ do j = 1, my
+ do i = 1, mx
+ slopx = (sh(ip1(i), j) - sh(im1(i), j)) * dxinv3(i, j)
+ slopy = (sh(i, jp1(j)) - sh(i, jm1(j))) * dyinv3(i, j)
+ ! slopGE ...... Cosine of Fall Line Angle
+ slopGE(i, j) = sqrt(slopx * slopx + slopy * slopy)
+ slopGE(i, j) = cos(atan(slopGE(i, j)))
+ ! omenor : Fall Line Azimuth (Upslope Direction)
+ if(abs(slopx) > zero) then
+ omenor = atan(slopy / slopx)
+ if(slopx < zero) &
+ omenor = omenor + pi
+ if(omenor > pi) &
+ omenor = -2.0d0 * pi + omenor
+ if(omenor < -pi) &
+ omenor = 2.0d0 * pi + omenor
+ else
+ if(slopy > zero) then
+ omenor = 0.5d0 * pi
+ else
+ omenor = 1.5d0 * pi
+ endif
+ endif
+ ! omenGE(i,j) : Fall Line Azimuth (Downslope Direction)
+ ! (in MAR Reference Frame)
+ ! (positive counterclockwise)
+ omenGE(i, j) = omenor - pi
+ enddo
+ enddo
+ ! +--Mountains Mask
+ ! + ~~~~~~~~~~~~~~
+ momask = 1
+#endif
+#if(MM)
+ if(momask /= 1) stop'++++++++ Preprocessing Error: #AZ not removed ++++++++++++++'
+ dxdx = dx * dx
+ daziGE = 2.0d0 * pi / n_azim
+ do k_azim = 1, n_azim
+ azim_0 = (k_azim - 1) * daziGE
+ azim_1 = k_azim * daziGE
+ do j = 1, mmy
+ do i = 1, mmx
+ cmntGE(i, j, k_azim) = 0.0d00
+ enddo
+ enddo
+ if(abs(cos(azim_0)) > abs(sin(azim_0))) then
+ nax = mx1 / 2
+ else
+ nax = my1 / 2
+ endif
+ nal = 30
+ nax = min(nax, nal)
+ do na = 1, nax
+ na2 = na / 2
+ na2 = max(na2, 1)
+ azimdd = daziGE / na
+ do j = 1, mmy
+ do i = 1, mmx
+ WKxy1(i, j) = 0.0d00
+ WKxy2(i, j) = 0.0d00
+ enddo
+ enddo
+ do ka = 1, na
+ azimut = azim_0 + azimdd * (ka - 0.5d0)
+ azimxx = (na + demi) * cos(azimut)
+ i_azim = azimxx
+ azimxa = abs(azimxx)
+ azimxs = sign(unun, azimxx)
+ azimyy = (na + demi) * sin(azimut)
+ j_azim = azimyy
+ azimya = abs(azimyy)
+ azimys = sign(unun, azimyy)
+ if(i_azim == 0 .and. j_azim == 0) then
+ if(azimxa > azimya) then
+ i_azim = azimxs
+ else
+ j_azim = azimys
+ endif
+ endif
+ do j = 2, my1
+ j_azmn = 1 - j
+ j_azmx = my - j
+ do i = 2, mx1
+ i_azmn = 1 - i
+ i_azmx = mx - i
+ nocoun = 0
+ if(j_azim > j_azmx .or. j_azim < j_azmn) nocoun = 1
+ if(i_azim > i_azmx .or. i_azim < i_azmn) nocoun = 1
+ if(nocoun == 1) go to 150
+ ddxx_2 = i_azim * i_azim * dxdx
+ ddyy_2 = j_azim * j_azim * dxdx
+ ddxy_2 = ddxx_2 + ddyy_2
+ ! Correction for Earth Curvature
+ ddzz = sh(i + i_azim, j + j_azim) - sh(i, j) &
+ - sqrt(earthr * earthr + ddxy_2) + earthr
+ ddzz = max(ddzz, zero)
+ tmnt_2 = ddzz * ddzz / ddxy_2
+ cmnt = sqrt(tmnt_2 / (unun + tmnt_2))
+ WKxy1(i, j) = WKxy1(i, j) + cmnt
+ WKxy2(i, j) = WKxy2(i, j) + unun
+150 continue
+ enddo
+ enddo
+ enddo
+ do j = 2, my1
+ do i = 2, mx1
+ if(WKxy2(i, j) > 0.d0) then
+ WKxy1(i, j) = WKxy1(i, j) / WKxy2(i, j)
+ cmntGE(i, j, k_azim) = max(WKxy1(i, j), cmntGE(i, j, k_azim))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+#if(AZ)
+ endif
+
+ ! +--Sun Azimuth
+ ! + ~~~~~~~~~~~~~
+ do j = 1, my
+ do i = 1, mx
+ WKxy3(i, j) = max(epsi, WKxy3(i, j))
+ ! comes: Cosine of Sun Azimuth
+ comes = (sd - slatGE(i, j) * czenGE(i, j)) &
+ / (clatGE(i, j) * WKxy3(i, j))
+ ! somes: Sine of Sun Azimuth
+ somes = (cd * WKxy4(i, j)) / WKxy3(i, j)
+ if(abs(comes) > zero) then
+ omesun = atan(somes / comes)
+ if(comes < zero) omesun = omesun + pi
+ if(omesun > pi) omesun = -2.0d0 * pi + omesun
+ if(omesun < -pi) omesun = 2.0d0 * pi + omesun
+ else
+ if(somes > zero) then
+ omesun = 0.5d0 * pi
+ else
+ omesun = 1.5d0 * pi
+ endif
+ endif
+
+ if(i == iSND .and. j == jSND) omeswr = omesun / degrad
+ ! omesun : Sun Azimuth (in MAR Reference Frame)
+ ! (positive counterclockwise)
+ omesun = -2.0d0 * pi + omesun + GEddxx * degrad
+ ! +--Minimum Zenithal Distance
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~
+ czmnGE(i, j) = 0.0d00
+#endif
+#if(MM)
+ r_azim = omesun / daziGE
+ k_azim = r_azim
+ if(k_azim <= 0) then
+ r_azim = r_azim + n_azim
+ k_azim = k_azim + n_azim
+ endif
+ knazim = k_azim + 1
+ if(knazim > n_azim) knazim = knazim - n_azim
+ czmnGE(i, j) = cmntGE(i, j, k_azim) + (r_azim - k_azim) &
+ * (cmntGE(i, j, knazim) - cmntGE(i, j, k_azim))
+#endif
+#if(AZ)
+ ! +--Cosine of Solar Normal Angle
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ cverGE(i, j) = slopGE(i, j) * czenGE(i, j) &
+ + WKxy3(i, j) * slopGE(i, j) * sqrt(unun - slopGE(i, j)) &
+ * cos(omesun - omenGE(i, j))
+ cverGE(i, j) = max(zero, cverGE(i, j))
+ if(czenGE(i, j) <= czmnGE(i, j)) cverGE(i, j) = 0.0d00
+ enddo
+ enddo
+ ! +--Output
+ ! + ======
+#endif
+#if(MM)
+ if(iterun == 0) then
+ ni1 = imez / 20 + 1
+ ni2 = imez / 20 + 1
+ nj1 = jmez / 20 + 1
+ nj2 = jmez / 20 + 1
+ do nj = nj2, nj1, -1
+ j1 = (nj - 1) * 20 + 1
+ j2 = nj * 20
+ do ni = ni1, ni2
+ i1 = (ni - 1) * 20 + 1
+ i2 = ni * 20
+ write(4, 60)(i, i=i1, i2), &
+ (j,(1.d-3 * sh(i, j), i=i1, i2), j=j2, j1, -1)
+60 format(///, 'TOPOGRAPHY', &
+ /, '==========', /, 4x, 20i4, /,(i4, 20f4.1))
+
+ do k_azim = 1, n_azim
+ azimut = (k_azim - 0.5d0) * daziGE / degrad
+ write(4, 61) azimut, &
+ (i, i=i1, i2), &
+ (j,(cmntGE(i, j, k_azim), i=i1, i2), j=j2, j1, -1)
+61 format(///, 'AZIMUTH ', f6.1, &
+ /, '================', /, 4x, 20i4, /,(i4, 20f4.2))
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+
+ if((jmmMAR == 0 .and. jssMAR == 0 .and. &
+ ((IO_loc >= 2 .and. jhurGE == 0) .or. &
+ (IO_loc >= 2 .and. mod(jhurGE, 3) == 0) .or. &
+ (IO_loc >= 3))) .or. &
+ IO_loc >= 7) then
+
+ ahor = timh + GElonh(iSND, jSND) - 12.d0 - et
+ zenitr = acos(czenGE(iSND, jSND)) / degrad
+#if(AZ)
+ anormr = acos(cverGE(iSND, jSND)) / degrad
+ omenwr = GEddxx - omenGE(iSND, jSND) / degrad
+ if(omenwr < 0.) omenwr = omenwr + 360.d0
+ if(omenwr > 360.) omenwr = omenwr - 360.d0
+ omeswr = 360.d0 - omeswr
+ if(omeswr < 0.) omeswr = omeswr + 360.d0
+ if(omeswr > 360.) omeswr = omeswr - 360.d0
+#endif
+
+ write(4, 1) GElat0, GElon0, jdarGE, mmarGE, jhurGE, minuGE, jsecGE
+1 format(/, ' lat.=', f6.1, 3x, 'long.=', f7.1, 4x, 'date :', i3, '-', i2, &
+ ' / ', i2, ' h.UT', i3, ' min.', i3, ' sec.')
+ write(4, 2) iSND, jSND, GElatr(iSND, jSND) / degrad, GElonh(iSND, jSND)
+2 format(' Sounding at (', i3, i3, ') / (', f6.2, 'dg,', f6.2, 'ho)')
+ write(4, 3) rsunGE * cverGE(iSND, jSND), ahor, zenitr &
+ , delta
+3 format(' Insolation [W/m2] = ', f7.2, ' Hor.Angle = ', f7.2, &
+ ' Zenith.Angle = ', f7.2 &
+ , /, ' Solar Declination = ', f7.2)
+
+ if(lhc == -1) &
+ write(4, 4) tlsrGE, timdl, tlssGE
+4 format(' Sun Rise Time [h] = ', f7.2, ' Day Leng. = ', f7.2, &
+ ' Sun Set Time = ', f7.2, ' -- POLAR NIGHT --')
+ if(lhc == 0) &
+ write(4, 5) tlsrGE, timdl, tlssGE
+5 format(' Sun Rise Time [h] = ', f7.2, ' Day Leng. = ', f7.2, &
+ ' Sun Set Time = ', f7.2, ' -- SOLAR TIME --')
+ if(lhc == 1) &
+ write(4, 6) tlsrGE, timdl, tlssGE
+6 format(' Sun Rise Time [h] = ', f7.2, ' Day Leng. = ', f7.2, &
+ ' Sun Set Time = ', f7.2, ' -- MIDNIGHT SUN --')
+ endif
+
+ ! +--Work Arrays Reset
+ ! + =================
+#if(AZ)
+ do j = 1, my
+ do i = 1, mx
+#endif
+#if(MM)
+ WKxy1(i, j) = 0.d0
+ WKxy2(i, j) = 0.d0
+#endif
+#if(AZ)
+ WKxy3(i, j) = 0.d0
+ WKxy4(i, j) = 0.d0
+ enddo
+ enddo
+#endif
+ return
+end
diff --git a/MAR/code_mar/qsat0d.f90 b/MAR/code_mar/qsat0d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..75ce8319f71e3f66fba04e452af0253fdae6866f
--- /dev/null
+++ b/MAR/code_mar/qsat0d.f90
@@ -0,0 +1,49 @@
+function qsat0D(ttq, ss, pstar, pt, lsf)
+ ! +------------------------------------------------------------------------+
+ ! | MAR PHYSICS Mc 30-05-2007 MAR |
+ ! | Function qsat0D computes the Saturation Specific Humidity (kg/kg) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : ttq : Air Temperature (K) |
+ ! | ^^^^^^^ pstar * ss + pt: Pressure of sigma level ss (kPa) |
+ ! | |
+ ! | OUTPUT : esat: Saturation Vapor Pressure (hPa) |
+ ! | ^^^^^^^ qsat0D: Saturation Specific Humidity (kg/kg) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+
+ implicit none
+
+ real qsat0D, ttq, ss, pstar, pt
+ integer lsf
+
+ ! +--Local Variables
+ ! + ================
+
+ real pr, esat
+ real, parameter :: tfreeze = 273.16d0
+
+ pr = 10.d0 * (pstar * ss + pt)
+ ! +...pr : pressure (hPa)
+
+ if(ttq >= tfreeze .or. lsf == 0) then
+ esat = 6.1078d0 * exp(5.138d0 * log(tfreeze / ttq)) &
+ * exp(6827.d0 * (unun / tfreeze - unun / ttq))
+ ! +... esat : saturated vapor pressure with respect to water
+ ! +*** Dudhia (1989) JAS, (B1) and (B2) p.3103
+ ! + See also Pielke (1984), p.234 and Stull (1988), p.276
+ else
+ esat = 6.107d0 * exp(6150.d0 * (unun / tfreeze - unun / ttq))
+ ! +... esat : saturated vapor pressure with respect to ice
+ ! +*** Dudhia (1989) JAS, 1989, (B1) and (B2) p.3103
+ endif
+
+ ! + ******
+ qsat0D = max(eps9, .622d0 * esat / (pr - .378d0 * esat))
+ ! + ******
+
+ return
+end
diff --git a/MAR/code_mar/qsat2d.f90 b/MAR/code_mar/qsat2d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2ca4023247009c4eebe35c21d8baa9a11d479dd5
--- /dev/null
+++ b/MAR/code_mar/qsat2d.f90
@@ -0,0 +1,127 @@
+subroutine qsat2D(tair2D, pst2D, tsrf2D, qvsi2D, qvsw2D)
+
+ ! +------------------------------------------------------------------------+
+ ! | MAR PHYSICS Mc 30-05-2007 MAR |
+ ! | subroutine qsat2D computes the Saturation Specific Humidity (kg/kg) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : tair2D: Air Temperature (K) |
+ ! | pst2D: Model Pressure Thickness (kPa) |
+ ! | tsrf2D: Surface Air Temperature (K) |
+ ! | |
+ ! | OUTPUT : qvsi2D: Saturation Specific Humidity over Ice (kg/kg) |
+ ! | ^^^^^^^ qvsw2D: Saturation Specific Humidity over Water (kg/kg) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+
+ implicit none
+
+ ! Input - Output
+ ! ==============
+ ! in
+ ! --
+ real, intent(in) :: tair2D(klon, klev)
+ real, intent(in) :: pst2D(klon)
+ real, intent(in) :: tsrf2D(klon)
+ ! out
+ ! ---
+ real, intent(out) :: qvsi2D(klon, klev + 1)
+ real, intent(out) :: qvsw2D(klon, klev + 1)
+
+ ! +--Local Variables
+ ! + ===============
+
+ integer i, j, k, m
+ integer il, klq
+
+ real :: W2xyz5(klon, klev + 1)
+ real :: W2xyz6(klon, klev + 1)
+ real :: W2xyz7(klon, klev + 1)
+ real :: W2xyz8(klon, klev + 1)
+
+ real WatIce, ExpWat, ExpWa2, ExpIce
+
+ ! +--DATA
+ ! + ====
+ data WatIce/273.16e0/
+ data ExpWat/5.138e0/
+ data ExpWa2/6827.e0/
+ data ExpIce/6150.e0/
+
+ ! +--Work Area Init
+ ! + ===============
+ do klq = 1, klev + 1
+ do il = 1, klon
+ W2xyz5(il, klq) = 0.0
+ W2xyz6(il, klq) = 0.0
+ W2xyz7(il, klq) = 0.0
+ W2xyz8(il, klq) = 0.0
+ enddo
+ enddo
+
+ ! +--Temperature (K) and Pressure (hPa)
+ ! + ==================================
+
+ do klq = 1, klev
+ do il = 1, klon
+ W2xyz5(il, klq) = tair2D(il, klq)
+ W2xyz6(il, klq) = (pst2D(il) * sigma(klq) + ptopDY) * 10.0d0
+ enddo
+ enddo
+
+ do il = 1, klon
+ W2xyz5(il, klev + 1) = tsrf2D(il)
+ W2xyz6(il, klev + 1) = (pst2D(il) + ptopDY) * 10.0d0
+ enddo
+
+ ! +--Saturation Vapor Pressure over Ice
+ ! + ==================================
+
+ do klq = 1, klev + 1
+ do il = 1, klon
+ ! +... Dudhia (1989) JAS, (B1) and (B2) p.3103
+ W2xyz7(il, klq) = 6.1070d0 * exp(ExpIce * (unun / WatIce - unun / W2xyz5(il, klq)))
+
+ W2xyz8(il, klq) = .622d0 * W2xyz7(il, klq) &
+ / (W2xyz6(il, klq) - .378d0 * W2xyz7(il, klq))
+
+ ! +--Saturation Vapor Pressure over Water
+ ! + ====================================
+ ! +... Dudhia (1989) JAS, (B1) and (B2) p.3103
+ ! + See also Pielke (1984), p.234 and Stull (1988), p.276
+ W2xyz7(il, klq) = 6.1078d0 * exp(ExpWat * log(WatIce / W2xyz5(il, klq))) &
+ * exp(ExpWa2 * (unun / WatIce - unun / W2xyz5(il, klq)))
+ ! +... Saturation Vapor Specific Concentration over Water
+ ! + (even for temperatures less than freezing point)
+ qvsw2D(il, klq) = max(eps9, .622d0 * W2xyz7(il, klq) &
+ / (W2xyz6(il, klq) - .378d0 * W2xyz7(il, klq)))
+
+ ! +--Water Phase Discriminator
+ ! + =========================
+ ! +... W2xyz7(il,klq) = 1 if Tair > 273.16
+ ! + 0 if Tair < 273.16
+ W2xyz7(il, klq) = max(zero, sign(unun, W2xyz5(il, klq) - WatIce))
+
+ ! +--Saturation Vapor Specific Concentration over Ice
+ ! + ================================================
+ ! +
+ qvsi2D(il, klq) = max(eps9, qvsw2D(il, klq) * W2xyz7(il, klq) &
+ + W2xyz8(il, klq) * (unun - W2xyz7(il, klq)))
+
+ ! +--Work Area Reset
+ ! + ===============
+ W2xyz5(il, klq) = 0.0
+ W2xyz6(il, klq) = 0.0
+ W2xyz7(il, klq) = 0.0
+ W2xyz8(il, klq) = 0.0
+ enddo
+ enddo
+
+ return
+endsubroutine qsat2D
diff --git a/MAR/code_mar/qsat3d.f90 b/MAR/code_mar/qsat3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..90d53bbc810644852cbaa69e14bfcea6ad973612
--- /dev/null
+++ b/MAR/code_mar/qsat3d.f90
@@ -0,0 +1,104 @@
+subroutine qsat3d
+ ! +------------------------------------------------------------------------+
+ ! | MAR PHYSICS Mc 30-05-2007 MAR |
+ ! | subroutine qsat3d computes the Saturation Specific Humidity (kg/kg) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : TairSL: Surface Air Temperature (K) |
+ ! | ^^^^^^^ TairDY: Air Temperature (K) |
+ ! | pstDY: Model Pressure Thickness (kPa) |
+ ! | |
+ ! | OUTPUT : qvswDY: Saturation Specific Humidity over Water (kg/kg) |
+ ! | ^^^^^^^ qvsiDY: Saturation Specific Humidity over Ice (kg/kg) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd, only: sigma
+ use mar_dy, only: pstDY, ptopDY, tairDY, qvswDY, qvsiDY
+ use mar_sl, only: TairSL
+ use mar_wk, only: WKxyz5, WKxyz6, WKxyz7, WKxyz8
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ real WatIce, ExpWat, ExpWa2, ExpIce
+
+ ! +--DATA
+ ! + ====
+ data WatIce/273.16e0/
+ data ExpWat/5.138e0/
+ data ExpWa2/6827.e0/
+ data ExpIce/6150.e0/
+
+ ! +--Temperature (K) and Pressure (hPa)
+ ! + ==================================
+
+ !$OMP PARALLEL do default(shared) private(i,j,k)
+ do j = 1, my
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz5(i, j, k) = tairDY(i, j, k)
+ WKxyz6(i, j, k) = (pstDY(i, j) * sigma(k) + ptopDY) * 10.0d0
+ enddo
+ ! end do
+ enddo
+
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz5(i, j, mzz) = TairSL(i, j)
+ WKxyz6(i, j, mzz) = (pstDY(i, j) + ptopDY) * 10.0d0
+ enddo
+ ! end do
+
+ ! +--Saturation Vapor Pressure over Ice
+ ! + ==================================
+ do k = 1, mzz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz7(i, j, k) = 6.1070d0 * exp(ExpIce * (unun / WatIce - unun / WKxyz5(i, j, k)))
+ ! +... Dudhia (1989) JAS, (B1) and (B2) p.3103
+
+ WKxyz8(i, j, k) = .622d0 * WKxyz7(i, j, k) / (WKxyz6(i, j, k) - .378d0 * WKxyz7(i, j, k))
+
+ ! +--Saturation Vapor Pressure over Water
+ ! + ====================================
+ WKxyz7(i, j, k) = 6.1078d0 * exp(ExpWat * log(WatIce / WKxyz5(i, j, k))) &
+ * exp(ExpWa2 * (unun / WatIce - unun / WKxyz5(i, j, k)))
+ ! +... Dudhia (1989) JAS, (B1) and (B2) p.3103
+ ! + See also Pielke (1984), p.234 and Stull (1988), p.276
+
+ qvswDY(i, j, k) = max(eps9, .622d0 * WKxyz7(i, j, k) &
+ / (WKxyz6(i, j, k) - .378d0 * WKxyz7(i, j, k)))
+ ! +... Saturation Vapor Specific Concentration over Water
+ ! + (even for temperatures less than freezing point)
+
+ ! +--Water Phase Discriminator
+ ! + =========================
+ WKxyz7(i, j, k) = max(zero, sign(unun, WKxyz5(i, j, k) - WatIce))
+ ! +... WKxyz7(i,j,k) = 1 if Tair > 273.16
+ ! + 0 if Tair < 273.16
+
+ ! +--Saturation Vapor Specific Concentration over Ice
+ ! + ================================================
+ qvsiDY(i, j, k) = max(eps9, qvswDY(i, j, k) * WKxyz7(i, j, k) &
+ + WKxyz8(i, j, k) * (unun - WKxyz7(i, j, k)))
+
+ ! +--Work Area Reset
+ ! + ===============
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+end
diff --git a/MAR/code_mar/qse_0d.f90 b/MAR/code_mar/qse_0d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..064bda4712f808c694c0797c783418944220c81e
--- /dev/null
+++ b/MAR/code_mar/qse_0d.f90
@@ -0,0 +1,77 @@
+function qse_0D(tt, sigma, ps, ptop)
+
+ !--------------------------------------------------------------------------+
+ ! Tue 30-Jun-2009 |
+ ! fonction qse_0D computes ECMWF saturation specific humidities |
+ ! |
+ !--------------------------------------------------------------------------+
+
+ implicit none
+
+ real ps, sigma, ptop, foeew, zcor
+ real tt, pp, qswT
+ real rkbol, rnavo, r, rmd, rmv
+ real rd, rv, restt, r2es, r3les
+ real r3ies, r4les, r4ies, retv, rtt
+ real qse_0D
+
+ data rkbol/1.380658e-23/
+ data rnavo/6.0221367e+23/
+ data rmd/28.9644/
+ data rmv/18.0153/
+ data restt/611.21/
+ data r3les/17.502/
+ data r3ies/22.587/
+ data r4les/32.19/
+ data r4ies/-0.7/
+ data rtt/273.16/
+
+ r = rnavo * rkbol
+ rd = 1000.*r / rmd
+ rv = 1000.*r / rmv
+ r2es = restt * rd / rv
+ retv = rv / rd - 1
+
+ pp = ps * sigma + ptop
+
+ foeew = r2es * exp((r3les * (tt - rtt)) / (tt - r4les))
+
+ qswT = foeew / (1000.*pp)
+ zcor = 1./(1.-retv * qswT)
+ qswT = qswT * zcor
+
+ qse_0D = qswT
+
+ ! FROM ECMWF
+ ! ----------
+ ! #
+ ! # computes qsat for water , USAGE qsat T P
+ ! #
+ ! set -e
+ ! if [ $1 ] ; then
+ ! dummy=0
+ ! else
+ ! echo "computes qsat for water; USAGE: qsat T P " >&2 ; exit 2
+ ! fi
+ ! if [ $2 ] ; then
+ ! dummy=0
+ ! else
+ ! echo "computes qsat for water; USAGE: qsat T P " >&2 ; exit 2
+ ! fi
+ ! echo $1 $2 | awk 'BEGIN { \
+ ! rkbol=1.380658e-23; rnavo=6.0221367e+23; r=rnavo*rkbol; \
+ ! rmd=28.9644; rmv=18.0153; rd=1000.*r/rmd; rv=1000.*r/rmv; \
+ ! restt=611.21; r2es=restt*rd/rv; r3les=17.502; r3ies=22.587; \
+ ! r4les=32.19; r4ies=-0.7;
+ ! retv=rv/rd-1; rtt=273.16}
+ ! {t=$1; p=$2; \
+ ! foeew=r2es*exp((r3les*(t-rtt))/(t-r4les)) ; \
+ ! qs=foeew/p ; zcor=1/(1-retv*qs);qs=qs*zcor ; print qs}'
+ ! #
+ ! # computes satration water vapor pressure over water as in the IFS
+ ! # usage: qsat T P ! T in K and P in Pa e.g. qsat 293 1e5
+ ! #
+
+ RETURN
+
+END
diff --git a/MAR/code_mar/radCEP.d/PHYradDRIV.d/PHYradDRIV.f.gz b/MAR/code_mar/radCEP.d/PHYradDRIV.d/PHYradDRIV.f.gz
new file mode 100644
index 0000000000000000000000000000000000000000..43837b055d1992bf58d13601818e45a2ae9ba02c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/PHYradDRIV.d/PHYradDRIV.f.gz differ
diff --git a/MAR/code_mar/radCEP.d/PHYradDRIV.d/PHYradDRIV.x.gz b/MAR/code_mar/radCEP.d/PHYradDRIV.d/PHYradDRIV.x.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2b023836a623ad9282f6613394ad86370e577856
Binary files /dev/null and b/MAR/code_mar/radCEP.d/PHYradDRIV.d/PHYradDRIV.x.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/PHYrad2CEP.F90.radaca.write.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/PHYrad2CEP.F90.radaca.write.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8798d429c0dbc2be3028c1f6c2e729e690d71f22
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/PHYrad2CEP.F90.radaca.write.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/_.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/_.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b04d5a157ca9e6e6df37a689a0931ef4bb80fa96
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/_.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/col2box.F90-NOT-CORRECT-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/col2box.F90-NOT-CORRECT-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6546b07987ea69bc09175195c9c0602b1233e5f6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/col2box.F90-NOT-CORRECT-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/col2box.F90.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/col2box.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e2a8c67a6143560001e39683f154fd60562efc59
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/col2box.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/legtri.F90.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/legtri.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3e24964eb84f36c34ce6b5b011af326a28e03859
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/legtri.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/qsat.F90.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/qsat.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e5d6354a908aacd8688ea9758d9c33bd40a6e051
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/qsat.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90-NOT-CORRECT-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90-NOT-CORRECT-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ed48dc71092beca278ba8e08717215c75cc5270e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90-NOT-CORRECT-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d8baec71842336b81d83e07b7fdc3dd8f9ad8505
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90.write.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90.write.gz
new file mode 100644
index 0000000000000000000000000000000000000000..313e3f62ae18496dc41319020a354a52c82735c8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radaca.F90.write.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90-BAK.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90-BAK.gz
new file mode 100644
index 0000000000000000000000000000000000000000..158f87a3e8fc6db694204aef2c176bee2c2c0c72
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90-BAK.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90.Original.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90.Original.gz
new file mode 100644
index 0000000000000000000000000000000000000000..803e5f44a37acd9ec9d7ddcf8b9f04c1d0b1de1c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90.Original.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..66d185003ae3f1a67f4e3191f715e5da10a8bc2a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radlsw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/Divers.d/radozc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radozc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6e6c570ba66bb165d6da619a3ee76444f5b4433c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/Divers.d/radozc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/PHYrad2CEP.F90.gz b/MAR/code_mar/radCEP.d/Source.d/PHYrad2CEP.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..26a66ff179406e5c535938cad6d61572e1969b0c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/PHYrad2CEP.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/StandA.F90.gz b/MAR/code_mar/radCEP.d/Source.d/StandA.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5c4c3802f6532a7f0f5b154bb8b3656f017914d4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/StandA.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2452bb548cdb7c598dbb72f6388f596c2ca2c0fe
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwb.F90-ERROR-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwb.F90-ERROR-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..37c73b3b5e5618735896a9373abcfedbe1a83dd3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwb.F90-ERROR-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwb.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwb.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c43ea73f6f3a0f01131b719cf4cf5839a236f32d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwb.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwbv.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwbv.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..93b4f01052e3ef4fc4d6b206fb6f55111955aecf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwbv.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9fb802e12f13998001783d7695489451fd603089
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwtt.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwtt.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c3bf23ad841cdcc3a4ad982388662e75901f9bcf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwtt.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwttm.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwttm.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..772d8449d446702501b58baa40ea4a8c82a44690
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwttm.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwu.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b08e90d5aab6c18e8d1233a4bfdf7afddd7001c6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwv.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwv.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6a7b3c3ae9e343dfc53d1a84d1f086e7257c6608
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwv.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvb.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvb.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ba0b9a16ce315e021405eb32d7e9df28a4d20bd6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvb.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvd.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvd.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..19b7d015aa7fdbba072f0439b07e0735e12156e9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvd.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2e271eabb4f93b588c9c7ec1ae950eee8ac87e8d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/lw____.d/lwvn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6324424cc357d869118edcb792754138a8781974
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwb.F90-ERROR-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwb.F90-ERROR-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..534ef4a19b7bd8e7a4150a50df7914d8819a9345
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwb.F90-ERROR-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwb.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwb.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bb49533fe62529b5b53dbd1d9d2032b47a2b4990
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwb.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwbv.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwbv.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9cfca8055c650d4b096798afb7fe297eb3576b1b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwbv.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..78a406aabdef4107b1a84595b7804b3de940f366
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwtt.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwtt.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b5bebc51ed21cdc631f75104658637fb7ce081fe
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwtt.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwttm.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwttm.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5de039bf5ce72a9a5a144466039843b9216d3f4f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwttm.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwu.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8bed90cc6ce0dbe5df057088696c4e34045283d9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwu.F90.original.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwu.F90.original.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a91d8d3f97016e3d7e96e09e99bfce7cc6015481
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwu.F90.original.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwv.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwv.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..02e242f1d892bc22a41a14da04964ddb5850fec6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwv.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwv.F90.original.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwv.F90.original.gz
new file mode 100644
index 0000000000000000000000000000000000000000..44972b1aeffdff428150932b45c1deb339ed30f6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwv.F90.original.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvb.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvb.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4ba4254d0d573586555e0e3d53755f880ac405d9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvb.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvd.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvd.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..78b554194ea25b232d11a48969d8a949ecacd4e7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvd.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2a950567354497c17bd6d67d1f6250468b5b490b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/olw___.d/olwvn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3e0444adadbc797a4fa28240dbce30336b7b1252
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4080967a56f5b1e301828071a4728195668f3d04
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3d363063ad5e64f812a5584f6daf7af10f8fd56b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a6ab12212c94ef1eca8617e5dc53e39b374df9be
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c03b22e840c3cd0ffbfb852688a5c06a1b54af8e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8e051883ed0ad8a359957579cb73ad1212530b24
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b5c17b122b6643b04cb2b799b64283d678100c50
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..862a278bb3960d57111f17cf3cb150ef357d1ac8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1f2eec8030732582edd39824afee9289eb5234a0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5c492513a02428779dd937abba4aa1c0b4d1245b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..711357aa278cb0f6472415f208c1580c491db663
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..668fd808709fd77230bd72871766d1babd9321d7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fcf423cc1beffa30cf85197b4a8991605eed8c0a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8aedeaab4c2eca6b1bbd8267ce7459407e0fb29f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0617d4de4181bfbe8721742fafb53d92a99fc584
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..36461150d224ee42a16bfd2bf0504c4d6e36622a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_cmbgb9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_ecrt_140gp.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_ecrt_140gp.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b478d2286063dc2585797df3dbf1864ebe9e355b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_ecrt_140gp.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_ecrt_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_ecrt_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..921514dff86126e0e75974cd0778eb01c926db3e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_ecrt_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_gasabs1a_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_gasabs1a_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c432494e67bafcf27d30237210fc0a1a1d63e454
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_gasabs1a_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_init_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_init_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..04b1c8a7d910535fc6e71b8a9ad125036ace21ec
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_init_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bf3e10db2cbf437059ed30739847a2e0ba71a3bf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..69221b1ab28e60cd72fcf63d66c4703baea3e2c7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fdd0f2be7701cecbde7f60cb1716c6547b33d722
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..21be69f5c6659fa7d436b49720e289a4a28afd18
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..23c92023a8b86459bdb2e7171a6d9afee880f533
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..55c49d44cdcf6a6ab86c5615e8d25c118b97f9cf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1cd2f9475ee12a8d25f30557d5958b6e2ce4d4f4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5cec7a4cf79c56ad6d553a622c85007116ba0c89
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f46f8bbb9aae6bb1063665459d5990294d322eb0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ea77217c8252b7a3fa7c57b7dd58cbc517000951
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.o-f90DB.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.o-f90DB.gz
new file mode 100644
index 0000000000000000000000000000000000000000..da9f8d8131f24e82017ae308bfc16903d499146e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.o-f90DB.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.o-ifcP3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.o-ifcP3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..715d8a83ccfc26c135ea2017a5dce968f141583c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb3.o-ifcP3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1dce3169f2c7560f33b29ff54c23a1feb1b6e975
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.o-f90DB.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.o-f90DB.gz
new file mode 100644
index 0000000000000000000000000000000000000000..75255083da73d22bc1310b30fef3283ad6b83e5f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.o-f90DB.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.o-ifcP3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.o-ifcP3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..525525e1c1ac358296e88fadbe2c6c0f90896b4e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb4.o-ifcP3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..af147af9b08d296e3fc858f8373b5b9c4a6f0a5e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.o-f90DB.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.o-f90DB.gz
new file mode 100644
index 0000000000000000000000000000000000000000..81d426dbdf36d6995ffc232e9439824cc639aa4c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.o-f90DB.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.o-ifcP3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.o-ifcP3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1863fe06dbd0899fa19c4e687b7d01e67e69e9f4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb5.o-ifcP3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d7480fafb735266bbea61ae3979e8c7312860b04
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8e1732b7cf3583e9d56e9a1cf2cdfbb7a35001a1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..72299d9f267ec128a28e81111b2302c719f43a25
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..54a48b81f9a8b0ec9c47a47c984ff2e104afdfc9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_kgb9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rrtm_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rrtm_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ee4ee074a218bee88839d984a0db4cfecdbd80d4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rrtm_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rtrn1a_140gp.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rtrn1a_140gp.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..65d0e803501c7989df85cba64d5533a51cf8546d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rtrn1a_140gp.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rtrn1a_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rtrn1a_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ba76bb0cd00e2ce1225bc1d41db95f37ea3ef93d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_rtrn1a_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_setcoef_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_setcoef_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1ddf8bec092dc18701ea93c880a35c7c536155a8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_setcoef_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a56c8988c2dc1e8f19e60a2fafa5703ff81272e7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..00ff52250602f7758c38e17038030df37e482a4f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1aaa27bd30ad2ad2b575ae83d7f1f31f1dfaf680
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..54e4369bb6a4ebcf5ce6b5e352172ee2f6fe4e39
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..aad4e6a533a7c9a5190302a79d84c5ee26e36e23
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2c2fdfe411890bd1aa0c9c2b83437fa0b171ecd3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ef3c5a4b6a749929cc3e821762c57a137bcc951d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c4fb702ee821fb96de51819b4f75ca6454b6ff66
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol2.F90.OLD.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol2.F90.OLD.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8cbf3a590efaf0d823fc08f578175dee449db98e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol2.F90.OLD.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b4e85577e52e801cf8192526ab481d75af66b99d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1aedb4ad4ace7d8978aa05dd6a81e5c74d2dbbe9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5248c1af763c0dcb65770da608b9e8ad7ddb8697
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bde9363a01807860bf0a0eaf7b87a3ef8374b73a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..48bd613c3f941ce08680596f25f58f4c59a2041a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f981247cebaad89cb11d7ec3030401882308b541
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..09cab3f798bc655d7bc15975c39163eb06f68bf4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..617d8ae8bb3727225fd0eeca68eabee63e1a929e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d.NOsplit/rrtm_taumol9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..930d37352969009ce86ed19bb458b67fda169548
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..befae2317dfb3e5900e891ab99d5afc5ec923e03
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f130e2f5a784349cd7eb2cac51dfdead20dffd4d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..96574c83c24421f9f9acb96e828de6b700287ae0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d39f727cc166bbd5cd9827bd69c2929471f54b03
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..030f1498ceac2c855e6e7341260e1086f5e51289
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..14b22b6f1494d1a7a9f9caa23ea929df4bc2b5de
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2124008c2a276bd16dcb0c7d33158afc92567779
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..66f930027c90ee077efb97a6bb6968f35412f8ed
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..edeccbd1b33e168a8800b86f6d17fba70a9e849e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cc3cc2671010fa7cf4477d24c0e828ac582a5fdd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..eeedc73f596f2c3d06ac4769d1746e826e6b5c2e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ccbd820bcc76a9bbc3605d30184cfdcc12b7df90
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..be821ac1f0aaa4b9927f0bd8407108f7355dccd4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8f1f64755095095f4182d90f28f7022a369e5648
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4cfd1f3f12d534f25abd555e824ebd4eb9c8de99
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_cmbgb9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b478d2286063dc2585797df3dbf1864ebe9e355b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..921514dff86126e0e75974cd0778eb01c926db3e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.write.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.write.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f303b87524e4350b41cb8c193d7c8786cda537fc
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_ecrt_140gp.F90.write.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_gasabs1a_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_gasabs1a_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c432494e67bafcf27d30237210fc0a1a1d63e454
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_gasabs1a_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_gasabs1a_140gp.F90.write.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_gasabs1a_140gp.F90.write.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8617c70f5ad51f91297b88dc1ff67f469501c3a8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_gasabs1a_140gp.F90.write.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_init_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_init_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..04b1c8a7d910535fc6e71b8a9ad125036ace21ec
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_init_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_init_140gp.F90.write.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_init_140gp.F90.write.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2fca3d0a202b0a8f0f00e742647b2f999ea83140
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_init_140gp.F90.write.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cb58b1308020b68d0747de080c9c1793408d6ecf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a21fdc85b3670e049089039be46aa0968a0e0509
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb10.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb10.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a13b05049d5aa403cc88c13de8e60f042f3e56b0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb10.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..69221b1ab28e60cd72fcf63d66c4703baea3e2c7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb11.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb11.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..293d43e2db93b6e49212dd84eaadee1d9c4ebde2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb11.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fdd0f2be7701cecbde7f60cb1716c6547b33d722
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..773b78d386d099e660e9d5c5d93a1b6c70c017af
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..41ca7d04506ab9a24757c652d858d78edde11f6b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d36e5670987ab43044b66716e120daa113c5f2ee
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3d16b89b84d94ede82f02188265322f4e4b58021
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..707a8f1b5106f0bcf669462a281e092aaa79fc51
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb12_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..905fa68158c0349dc103d29e68f4e8fbaa407d17
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f437ba1991e7d445e52889a796c34d3d24c017bd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..43fd38cdd0edc06576c844341fbeebfed2937928
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e9a576fd9a90b69ab3ff2905c8aec61785d73208
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..92ee6c940996f2eed7e01804719f1501c1758f74
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb13_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb14.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb14.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..05f18244ccce7b41e81f8f5f40d4a3306a75e3a1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb14.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..55c49d44cdcf6a6ab86c5615e8d25c118b97f9cf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..19167a041ef7e4ea7bb3af17918e062f9f71b4a8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3528ef01ff7649024d27f507fe4f64ef19bfaeda
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..843c9254390cd9d5c7bc5829c87ce33856608f41
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d27a47d477076ded966b2221662ee243c9edb1b7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5b65f4cf91fed2ebc9bc45180f98b22fb936da20
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb15_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f14f926f27afb892021f49fcf0fa1ad29060e07a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5b065fbbb7eecfdb61e13a8b71e1953b0c1bee69
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5fcc890888e95fa3383aa7eb3abebe5ec7731c86
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f364029bd9e69d9c9c841e193785bbbf00d03814
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..05c70e2135ad08ab9c44992b27e1d202fdedf8aa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb16_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fcd83442529c6bd86d0db1e71c6576015b3138e7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ec015db1ebea2fdce62e6036f3a931227412cdc4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb1_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..94284619095c3d6c9aa94859c44fae04592abe2a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..65c25a78c34314e29d7d9274c45ec92beede0fc5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..10625ad5b7efed8e527c4d1892afc19338aef5a5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c046558f0ff66f911b57d4986a0342c7a5b69bb1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb2_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e73f27db9b613facd821e156e615941f584b39bc
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a4d7caa06f4ce39a327d2ee9f90941aff1745d20
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.o-f90DB.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.o-f90DB.gz
new file mode 100644
index 0000000000000000000000000000000000000000..da9f8d8131f24e82017ae308bfc16903d499146e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.o-f90DB.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.o-ifcP3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.o-ifcP3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..715d8a83ccfc26c135ea2017a5dce968f141583c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3.o-ifcP3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..76277542e144fa4594379faeab5b6ab5dafc35a3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4d77aa3f61f9aec14adc1cb3d7c0a0c197c6ffe5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..733012de2e0f98222b94bd1670f4e9bf7c280878
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ed493473b037f42e71c168b55410c9c64e8acb83
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c49eca86cd38d325c1f13e0e22171226ec00d3bb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2ef555d2333ad4ab9019344b155f536ad605cb84
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..badbcef93a46c8ec0e86b8307dda6a3c39326bcd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb3_B4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d89b215b0f18388af11b37758862543cdf1cea6c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b5e0a9c488d763f280976aac54adeb4a20b8bafa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.o-f90DB.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.o-f90DB.gz
new file mode 100644
index 0000000000000000000000000000000000000000..75255083da73d22bc1310b30fef3283ad6b83e5f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.o-f90DB.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.o-ifcP3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.o-ifcP3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..525525e1c1ac358296e88fadbe2c6c0f90896b4e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4.o-ifcP3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..142297c645f3029d286ba6924bd6517a7c35fa44
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3c46b9c36221ea6d294384f7f502cc050d10baef
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..700a37964f01fba9fc411baa74357fa493858b38
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..308415cb363a2dd436ac22c161214bd5b400153e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f2c2eb6f24fde9cc8bb9ab2acf210eb335f63735
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fa97d718b8bab6ae162f371da351242bea220000
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..03331afcc4fd498112c055b0b294f32bace6302e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb4_B4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..793803e8e836a5d3d91c64f6aa6835bca6615941
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2baf4389a6ed35a233340ed9f0ff03c49a98e4cd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.o-f90DB.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.o-f90DB.gz
new file mode 100644
index 0000000000000000000000000000000000000000..81d426dbdf36d6995ffc232e9439824cc639aa4c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.o-f90DB.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.o-ifcP3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.o-ifcP3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1863fe06dbd0899fa19c4e687b7d01e67e69e9f4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5.o-ifcP3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f75e60d21b9ac81251091433640199b3e28a5da0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..319956bf681b66705b93abe549b1885dc00afbf7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..19a8916758a9c4bbbc8a8ac4bca4e00e67dd4496
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8c814e8f9bee8d6806adfaedd30ebfe67b2a9e18
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..96bc4dfbf2933dc363e8366a20dbc40cdc4d7565
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7c75a5293e7aead26fc7905e84e9dc2116174bc5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..17b8d8c127537f1c04efe7e07c6db608502c766a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb5_B4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d7480fafb735266bbea61ae3979e8c7312860b04
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4e8bea71375231ef3c465e620ae0d08da26f9a34
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7f2773c291f43080ea5ad5e98f965c32f222d39e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9c466035c5a7b6dc331cf7df8929f14f12fed6df
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9af6e0277e83cfe611a733d2ed5b9c10bcaec2b4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e30d8e27def2e853b42e31510deea8cd50962eba
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_BB.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_BB.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a29dc0f4e905e4c4baf7a9263e45a69299838b1a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb7_BB.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb8.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb8.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..127763942835191424e0a87d5eb9143a07e9f5eb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb8.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..72299d9f267ec128a28e81111b2302c719f43a25
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fff0b413e3b13efc45d97fca5d09c4abc02f0eea
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8c1aea8ee8f72815a95d17d769b2e6f7f7a78c28
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_00.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_00.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bd32ccf8a825e95b1ca88bba37ecb079b2fd8dff
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_00.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_A1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_A1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7035e7a25c4a39fcf5dff15840af3b07bbb375ac
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_A1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_A2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_A2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..08999648146b190e171005bfa5e6ec0b5a335376
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_A2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_BB.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_BB.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..04f4b5e76d1222d5a8086e45bc4343e2b88ab8f7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_kgb9_BB.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rrtm_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rrtm_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d779fcc0d6ebab3972c728bf6d55c9c7e4b7e406
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rrtm_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..65d0e803501c7989df85cba64d5533a51cf8546d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ba76bb0cd00e2ce1225bc1d41db95f37ea3ef93d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.write.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.write.gz
new file mode 100644
index 0000000000000000000000000000000000000000..34cfc629fd95483eba200f582fbf1e3d3341e2b5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_rtrn1a_140gp.F90.write.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_setcoef_140gp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_setcoef_140gp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1ddf8bec092dc18701ea93c880a35c7c536155a8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_setcoef_140gp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..254d84d7ae1c3a99f65f00ec2ecaf6198b90837b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..611eea3caad18832bc7c53498621289935acb5de
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..66f7bec9bb9c48bf5193741641bd5d3b75269e08
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1b8a81326fb0bed59a5d6ca71ada969c4e4097c6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a15a356e40c4df6db0197113054c371723a7f519
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..143bbdfc421c26b07ec10bba9ed6d03971aec97a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..05545efd4d6ad3ab60bf94daa845692e5eab8212
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ca146044295f91c98d386df3fc2390a51d1dc068
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90-ERROR-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90-ERROR-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ca14ef55a7818e2e5732a1d3262d6529508f90ae
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90-ERROR-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90.OLD.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90.OLD.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8cbf3a590efaf0d823fc08f578175dee449db98e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90.OLD.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a79921dc87c9751487601c55be149a7d9f3b3d24
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e22b3a070faa4c28c412e1f909b287167f221ae5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.write.ABSA3.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.write.ABSA3.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b63bb609c40799e28b62a359f736bb2632b89f41
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.write.ABSA3.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.write.NoDebug.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.write.NoDebug.gz
new file mode 100644
index 0000000000000000000000000000000000000000..354779d6e9d1f2633a316e12a6fcfa09b35328aa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol3.F90.write.NoDebug.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..398a3d2b87febc6706e9b524d1ab031b7a2f2d13
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1151d6c2e5d932579e9552f2bf45215415faef22
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4e9ca71f480a30bcf4d6e42e6a4396b6e86191ed
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2021e67b908061e22792ed48325ab548fd6b72ce
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f044a5973c3fe12da5cf95767ee15e70e7f5a131
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0c519d1eec904a1e6fa597daad8017c32633a262
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/rrtm_taumol9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d198a461d61e4194ee0d79725c7617a062f3547f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9a1e5816add83ae012ec4b489b15c512509bce67
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..069705ee164b4513c2aadb45342abe7369200a10
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cef942aafaba3f738e28b360c092afe2e2a28110
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta13.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..385f2f83a95f65ead6ab488985f4a2466d8a2f3c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta14.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0de3ea3f63fab32194648a0bb09f761743ba7f41
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta15.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..96ed714fa6a294034393117ba6ba52c493a18d5d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta16.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..988f6b88a72c3ad9cc261707a6a5aee0b9d9d0e4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta2.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b4f58c27a5af04478c59b46a6c447915ae70bfa0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..313c570daa3acd3a2683d5b3c92bb9ca0405da4e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta4.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e42752b4571f04dfefcfcbde107dd92ae4d4b1ac
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta5.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..af04585308480a7153df10515c438cf44faa58ed
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta6.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2234df324990d64d3568914d09d6b6120271a142
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta7.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d83012236878841a181c814d545b61218488c5c0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta8.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9567874d02c33339315c97cb06e6f9419d1fdcaf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta9.F90.gz b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8195e5928befe40e8d1cc4bf7428f14c22f24e58
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/rrtm__.d/yoerrta9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerh.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerh.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6b1c9b4465e079110d29d0a186da962781fa95fa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerh.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerl.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerl.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..304a35650d7187aa834205da01f0f21bca07e68e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerl.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaersn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaersn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..88212f1aeef26216797befe69110df11d6760429
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaersn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerv.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerv.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..993576583287d70e379ce0f64df8a3812d7fc7f6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suaerv.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucld.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucld.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..32dec68049e478e7aae46cc7b30e6ecca64d5540
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucld.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucldp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucldp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..418b8f7fb1c9a6d56d6993a19a59b1d07960bee0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucldp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suclop.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suclop.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..22a633675137d5b3fcabde2e201a378d3a9982cb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suclop.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suclopn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suclopn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b5be7fb3b9d68f68e6e216f08e703e25ca8d474c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suclopn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucst.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucst.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..82bdf918ac02192c220de9119f2be9cd91788ce1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sucst.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaebc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaebc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..49f724cd1399bd570f57fcd00e99e2f3af2c0253
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaebc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaec.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaec.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..91e41dac879eae7487ccbc97b09a3a3afa575b6e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaec.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaeor.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaeor.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..39d7b00540992f3803a2a3d3ebe2fca72d2692de
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaeor.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaesd.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaesd.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ee0bcb1a99b90dcaa9afc4a2f21bcf6382b2f360
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaesd.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaess.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaess.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b4489a7bb4a684149ff0ad643ad13f2c468a0190
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaess.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaesu.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaesu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c7f22656fa3acfbc3c2cd58c2431757be872925e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecaesu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecozc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecozc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bde7273ce35db4406ec02396940211579f2e14ff
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecozc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecozo.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecozo.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c2236f428dfe0182921d4b34e4cfc847ecea228a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suecozo.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sulw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sulw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9c7cd25b3baa2b717a70ffd2ac5663a61ee0ca7c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sulw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sulwn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sulwn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..65a4557b6df82894a4817512ad80cd0d882b9a1d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/sulwn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suolwn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suolwn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..93d94b864c555b90af91addd4bb77e0f5e4dc72d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suolwn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suovlp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suovlp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9eb7689c598279cd76cb0c99ca7472558f5bd162
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suovlp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suovlp.F90.original.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suovlp.F90.original.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6cdec8b9c50062f89137dc268f3dc1797c890989
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suovlp.F90.original.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..51368e90d5a1ba88efdf12ef9f889b7614b875b8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90_1990.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90_1990.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0d44adafba37960aba91ca9713b5324faeb8864d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90_1990.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90_2090.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90_2090.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ab7d3617571fa11e23a83e647fad665609b4a0e2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surdi.F90_2090.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtab.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtab.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6a190028dbe1936020d773ea21672b70d785491b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtab.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtftr.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtftr.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ae1c46aba30b87a6913dec6d59d27c2eea9d9133
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtftr.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtpk.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtpk.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c1d0812434eda42321c83c9f2dbafe6f6b567a45
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtpk.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtrf.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtrf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7f83294232f47ffb546364a5e5161bfe29d5d2ef
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/surrtrf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/susw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/susw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a1556898573209b4cffa37e387fa3e5d249d780d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/susw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suswn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suswn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..09329043b18d37d3baf1ba7070fd84ce63553879
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d.NOsplit/suswn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerh.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerh.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6b1c9b4465e079110d29d0a186da962781fa95fa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerh.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerl.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerl.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..304a35650d7187aa834205da01f0f21bca07e68e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerl.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suaersn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaersn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..88212f1aeef26216797befe69110df11d6760429
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaersn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerv.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerv.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..993576583287d70e379ce0f64df8a3812d7fc7f6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suaerv.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/sucld.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/sucld.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..32dec68049e478e7aae46cc7b30e6ecca64d5540
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/sucld.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/sucldp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/sucldp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..418b8f7fb1c9a6d56d6993a19a59b1d07960bee0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/sucldp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suclop.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suclop.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..22a633675137d5b3fcabde2e201a378d3a9982cb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suclop.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suclopn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suclopn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b5be7fb3b9d68f68e6e216f08e703e25ca8d474c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suclopn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/sucst.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/sucst.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..48c09a951f039df14cf9b55410d8bd3ba4be01c4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/sucst.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2f161dd54e89a288964044272e9132ac529132d6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..95b03d532147a70b9f473d06b9b8c98ba7f1d473
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d1d1ffb054154a28c367c7574615ce2b5fd933b0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1cd43809ecf2b59837e2c0851f371d2b51154b66
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_03.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_03.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..81a0a8f235f3b1ad77bb57c9fa438e5935fd01bb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_03.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_04.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_04.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4879ead6a77c8e90d55925c658ea72c1e6bc4d8e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_04.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_05.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_05.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bd0234cf319135cd5d74f5516dc8bbf70d9a5efb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_05.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_06.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_06.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8973ac32f9e89e5d1916ae219472018043fd6e3a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_06.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_07.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_07.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8d62a21681a1b88527e2c28a79cffeb5e3567cc7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_07.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_08.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_08.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..eb102e5937c69a2ffa0e9bd2a66bf4b824746a57
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_08.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_09.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_09.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1a8cc41dd48e0ffd7571b7d04103f124ba35af03
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_09.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cca5b485c3f1ccf560f1753f63a3c187b36827cf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2a8b5a5c722ec325e3c0bdc1dfecfbfc64f171bb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..de249e9aba739e2f82c9600479b1f54833cdd9f5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaebc_12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaec.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaec.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e2841cc478917aebe9ad70474baba1bbcc967e63
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaec.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaec.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaec.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6d480240309117482b542becc7f10ce6658eeee0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaec.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..12dc4228f1225d4b82a0dc4c8babf482c4d3b681
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..73a8eb845af490d931feecb9c4b16e2c5de3f2b0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..46ac99f1ff1e7b163a776998922682195f624e34
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..704cdb8308d8f79625c92c2c969cb2aa32aab5dc
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_03.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_03.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d01537f94d9fd0162263f1d2de861adf81443f62
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_03.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_04.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_04.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d2b74d6f09913e65ce782e90188c55eb96b9f2c4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_04.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_05.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_05.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1bf86258dd1c1b3d88fe8ce2df6eee0346306906
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_05.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_06.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_06.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d980f98f81dc29887e2d99e7f58efc4b131e14a2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_06.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_07.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_07.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f59c61f0818ab3e61687274923b350d45e22e278
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_07.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_08.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_08.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..728f93fc7d20b3cbee0d4765a9a2eb7c840ae84c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_08.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_09.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_09.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7fa8ecaa4fcc996749e21cb4e4e4f1b374d963b1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_09.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b3afe506a9a93c17b3422f7ebf2e7d2ce23acbc9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c98fede01a6c7eefcaa0f719831236b93e880920
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b43f3c4fb288e3c0b2d2f798012a733ea3238e7c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaeor_12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..af06d39a5a4dbbefeb5a3fe0c49b63908722e333
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6a0ad8d021d9544517867645c28f4c9443d79764
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fb4e41a76e68cafd9a46a37d9d17e8397fb1d63f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..55b9f35e37b46da04e1f05f16eb786a0e3b1bb5a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_03.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_03.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..488ed7e52964d42fc6c3abad3e2a1a0f4fcdf856
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_03.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_04.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_04.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4391d8cf7bce5092a7a07f6f21ebbf7475408cd8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_04.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_05.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_05.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..33d62202f0651474587d6f17408b988c0e1d90dc
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_05.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_06.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_06.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9d71f952c592694e22ecaf002d116e6ecbfa8f0e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_06.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_07.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_07.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..40b955dbefbf1ef20abe072e1c14d5ce2d39ae64
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_07.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_08.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_08.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6bb474205f046b4a3ffe2e1b05c218dc5a69d758
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_08.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_09.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_09.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1031f35eecd1dd22a7f1f0fd488ba02c6a9e2833
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_09.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e2a071565ad21b13ee10e21a8a1b8684523223f6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..be32768a9a851e509b69a6c2e2607abc89b3c1a9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..97894bd66684fd90c9c1e04156b827d441083808
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesd_12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d91ed6b5a6913c52467a852cc4d252dbb822399a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8bde1a89c660e9084216bee37c832bbe39438726
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9e933ba8ba51a28ee974ba769cc2da02f21f67c5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..257fa80b751edcd626c84715cc8163410f22deff
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_03.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_03.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7fdb8687c0b18d3417c3425327b8a06a509e6a91
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_03.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_04.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_04.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e59560000651add376ee353a19780f708ade2a8a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_04.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_05.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_05.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bf588f4d8a6884d8582c4896b64bb106ce10064d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_05.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_06.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_06.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..45d805e137de6036dfacdf1e98286a50975013ad
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_06.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_07.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_07.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..12b2efa88fe0a9f8a69f984adab8741a7c6bfdaa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_07.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_08.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_08.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3e506adac3c86965d835999a7337b2cdb6984ba5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_08.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_09.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_09.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..78376773dadeb947d034f92d2966b92407560426
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_09.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..aa094b29e6aec609a9d3df29653a11822f8f480a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9735238e0ea0bd83deb1a3c85d80b70448ff1b32
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4a811f0e4d4767dcdd9f35c73e0944dd7ebfe0e5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaess_12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7bca3ee77850ba9922cbd995cee97c3e28f1d5d7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..226c8d1b31255e27a672dd821496fd13781c6e74
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_01.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_01.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..589e95235629b7f2b4478d9247b8cf44f8f74c2b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_01.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_02.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_02.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3b8b4ae038363156fdc10967e4c22bec50fcb365
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_02.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_03.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_03.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5488301a5ed50724853478c8c52312a7ad75d211
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_03.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_04.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_04.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9f043860c6fc8d57592167fb7729ef1a55e09b77
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_04.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_05.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_05.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..774f64493820ef2b3ac9af71cae05fda6c446f6f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_05.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_06.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_06.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8e20f53e731bad8483971b0f6df36bf32cbcd858
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_06.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_07.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_07.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..04b079837b7c95c9b2253ae253c9390d106e7e54
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_07.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_08.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_08.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c011149a47c712f734ea51ea9aba26f2de01ef01
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_08.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_09.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_09.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e495ae48a2d27deb5df8c14377ed64114404d67d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_09.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_10.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e3267cf172537a575c6e1c047eb10ddd7af34ac7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_11.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ec41b8e126a52cd80a591b4b1a5400f9d1647db9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_12.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a8159ea9aa5d8654506a775e478eb0bd257a66a4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecaesu_12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozc.F90-to-split.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozc.F90-to-split.gz
new file mode 100644
index 0000000000000000000000000000000000000000..25a18a16d4688752e8f6e87c78c89c3f7e02d1f0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozc.F90-to-split.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozc.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bde7273ce35db4406ec02396940211579f2e14ff
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozo.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozo.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c2236f428dfe0182921d4b34e4cfc847ecea228a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suecozo.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/sulw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/sulw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9c7cd25b3baa2b717a70ffd2ac5663a61ee0ca7c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/sulw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/sulwn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/sulwn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..65a4557b6df82894a4817512ad80cd0d882b9a1d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/sulwn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suolwn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suolwn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..93d94b864c555b90af91addd4bb77e0f5e4dc72d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suolwn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suovlp.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suovlp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9eb7689c598279cd76cb0c99ca7472558f5bd162
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suovlp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suovlp.F90.original.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suovlp.F90.original.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6cdec8b9c50062f89137dc268f3dc1797c890989
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suovlp.F90.original.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/surdi.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/surdi.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8bbe8e754ec7ccce26b4f9ed83f8f77a43ae0c3f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/surdi.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtab.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtab.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6a190028dbe1936020d773ea21672b70d785491b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtab.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtftr.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtftr.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ae1c46aba30b87a6913dec6d59d27c2eea9d9133
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtftr.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtpk.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtpk.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c1d0812434eda42321c83c9f2dbafe6f6b567a45
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtpk.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtrf.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtrf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7f83294232f47ffb546364a5e5161bfe29d5d2ef
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/surrtrf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/susw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/susw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a1556898573209b4cffa37e387fa3e5d249d780d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/susw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/su____.d/suswn.F90.gz b/MAR/code_mar/radCEP.d/Source.d/su____.d/suswn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..09329043b18d37d3baf1ba7070fd84ce63553879
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/su____.d/suswn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..51f675d8e8d06a4fe488865fd2db4137b897d55d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw1s.F90-NOT-CORRECT-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw1s.F90-NOT-CORRECT-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..08e8a462d8695be68d09d3331cb4980b5d5045f0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw1s.F90-NOT-CORRECT-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw1s.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw1s.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..903e45b72a35d96499681254355ecdcf36e5d8b7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw1s.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw2s.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw2s.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1407e4a10f55bcd901acfa6395ff3ab3f8ce0d1c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/sw2s.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swclr.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swclr.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..55201e172a412b0232aaa088e5e6f8670c5bea30
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swclr.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swde.F90-BAK.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swde.F90-BAK.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3dddea0e8f5a3fa7b4c0b5ee35a486fee6cf9b79
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swde.F90-BAK.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swde.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swde.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..45697f747f15dc0be7a683dbd16c23c36865a936
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swde.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swni.F90-NOT-CORRECT-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swni.F90-NOT-CORRECT-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d1007e0aef6a6a51b0cbb5fd9d9bd3dcc356b913
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swni.F90-NOT-CORRECT-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swni.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swni.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1cec30a6aa578c6d36664cb22b1f29dc903797dd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swni.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swr.F90-NOT-CORRECT-on-dexp.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swr.F90-NOT-CORRECT-on-dexp.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9fb13d91fb5c7a38f14cdbb5e7f904fd2577f91f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swr.F90-NOT-CORRECT-on-dexp.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swr.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swr.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1141c0a9a68080073cdb63934191960ded6ce825
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swr.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swtt.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swtt.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..401479b71f6fedd8a0bfad9c6e3f81f6c86cc4ad
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swtt.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swtt1.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swtt1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..44a94ced3374f929a0f1dcf19fff12502b988caf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swtt1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swu.F90-NOT-CORRECT-on-zahir.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swu.F90-NOT-CORRECT-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..19b1457bbaef1f2047197c16e417048ebf5de039
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swu.F90-NOT-CORRECT-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swu.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..48c98f4e7571b0ab6ada46a67dd6690a58596a31
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/Source.d/sw____.d/swuvo3.F90.gz b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swuvo3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e1c5e9e0ab49db434cc243b10f98f2ede366cae0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/Source.d/sw____.d/swuvo3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/fctast.h.gz b/MAR/code_mar/radCEP.d/include/fctast.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..759ea17e45d572ef237201028f6189c4a15a0aae
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/fctast.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/fcttim.h-ERROR-on-zahir.gz b/MAR/code_mar/radCEP.d/include/fcttim.h-ERROR-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..db7b01669be464c36337f36d15956ce0538f24d2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/fcttim.h-ERROR-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/fcttim.h.gz b/MAR/code_mar/radCEP.d/include/fcttim.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..06a8c1529abc3017a68fd8a0a9e9bebc011f8fff
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/fcttim.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/fcttre.h.gz b/MAR/code_mar/radCEP.d/include/fcttre.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d19a769ab3b892de56d74776e195aadba2e8c717
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/fcttre.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/fcttrm.h.gz b/MAR/code_mar/radCEP.d/include/fcttrm.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c4e43b75344c442aa12c3c138a9086bb261adb98
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/fcttrm.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/naerad.h.gz b/MAR/code_mar/radCEP.d/include/naerad.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..215e34c96eb097820faf1e581d18d0308a169e1f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/naerad.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/include/tsmbkind.h.gz b/MAR/code_mar/radCEP.d/include/tsmbkind.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1d3fe125c29f6331b84e051e4410ed2356792f6f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/include/tsmbkind.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_0/parkind1.F90.gz b/MAR/code_mar/radCEP.d/module.d_0/parkind1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..949a07adf1536af9ab355ecddb0b9428ec84e36b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_0/parkind1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_0/parkind2.F90.gz b/MAR/code_mar/radCEP.d/module.d_0/parkind2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8937b72d0a854f5a43500e553a7ae4a0ed240ddc
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_0/parkind2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_0/strhandler.F90-ERROR-on-zahir.gz b/MAR/code_mar/radCEP.d/module.d_0/strhandler.F90-ERROR-on-zahir.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4aa03e2853abf2aead9a2ae1147f88fd68b70207
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_0/strhandler.F90-ERROR-on-zahir.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_0/strhandler.F90.gz b/MAR/code_mar/radCEP.d/module.d_0/strhandler.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..07e164c7b0d240364cacc813e544c5d3503c514f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_0/strhandler.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parcli.F90.ORI.gz b/MAR/code_mar/radCEP.d/module.d_1/parcli.F90.ORI.gz
new file mode 100644
index 0000000000000000000000000000000000000000..842bb8ee1ba7bf412470196626fc6dbc44b97518
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parcli.F90.ORI.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parcli.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parcli.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3ff801eb191cf29ea1f5d22ee9f694955f731f03
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parcli.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parclimf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parclimf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c2230f323dc678ae4a1321e57a655a570ad2a2d1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parclimf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parcma.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parcma.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7adb7c43410fd9aa8dfa38781f2d0abd4e6801c4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parcma.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/pardim.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/pardim.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..876223c2eb39b6edfcc407acf2791fd71bfbd26e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/pardim.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/pardimo.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/pardimo.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..43046c3dbbf727cbee288454e6078edb4e00e712
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/pardimo.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parerob.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parerob.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6dafb380717ca989b6027557310e71ce812ad642
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parerob.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parfpos.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parfpos.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6d58e2c02e8d5ca6b08bb93afaa187200c527eb2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parfpos.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/pargc5.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/pargc5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c751222f69c257f297d13f040ddce66eeebb4747
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/pargc5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parptrs.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parptrs.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3abed1572940309d67c876f24f15738d7d7421a2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parptrs.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parrint.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parrint.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3c76484a16766a978e4317c304d8cc85e83ed56b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parrint.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parrrtm.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/module.d_1/parrrtm.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..75c1e0e0702cb7456e397982b32a6aa758e440cd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parrrtm.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parrrtm.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parrrtm.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..129608aa6e5badc6aad30c994bb86b3119e1b69d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parrrtm.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parrtm1d.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/module.d_1/parrtm1d.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8c4af57146a8317325775590558917b6cf97764a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parrtm1d.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/parrtm1d.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/parrtm1d.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e7f4e650c78267d4f3ff80202febbf27bc5811a2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/parrtm1d.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/script.bash.gz b/MAR/code_mar/radCEP.d/module.d_1/script.bash.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0a58c95707f3f4dba500c705bfdbf9766b67c9d5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/script.bash.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/tsmbkind.h.gz b/MAR/code_mar/radCEP.d/module.d_1/tsmbkind.h.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1d3fe125c29f6331b84e051e4410ed2356792f6f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/tsmbkind.h.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeaer.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeaer.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4b3694d3675258eeec6cf554aa2140ae79465652
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeaer.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeaerc.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeaerc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a1369ea54c015a500884c0d279fc38b3710f16de
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeaerc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeaerd.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeaerd.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a77c15dc22a6c9132d52d16f68d58110895fe50e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeaerd.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeast.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeast.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..29472dfeec6c9322d8e6f757321f0f374d79e18e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeast.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoecld.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoecld.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0c995df28e0cd6b795e629ee5c5d0499a64c208a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoecld.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoecldp.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoecldp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c694483e4ab9b9ff4581d912ceecb842a9ff20d7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoecldp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeclop.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeclop.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9bc0e7b377c0d94b8466cddadc6f347345fdf8ac
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeclop.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoedbug.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoedbug.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a9ab1a2ff4608f1f91a41df12e2c2c41ac59c0d4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoedbug.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoelw.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoelw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..71179b6ab80c8e520b61722748d74f09f9cf2609
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoelw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoemeth.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoemeth.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e73856a0412ecdd874d85abd549ccdc1508c880b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoemeth.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoencst.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoencst.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..227f3e7db1bceb1b9da8a089675ffcb73c7e8bcb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoencst.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeolw.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeolw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4058a86ea177db3ebc8da86d45ea81016b2a2ed1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeolw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeovlp.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeovlp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..66a8f561a881f47de99c927cfb4eb47c20dd4b5c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeovlp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeozoc.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeozoc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ce9a6f745bb2d13a05b33071fbc381dee32811aa
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeozoc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoephli.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoephli.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..664b1b3dd1fcd64951742e4937b6fbef951eb13b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoephli.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoephy.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoephy.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..999c398e55fc9938126c0a0e41005e75ea074b0d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoephy.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerad.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerad.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e6b006c93d86e75b296a3bf945e6cdc99b1dffb2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerad.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerdi.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerdi.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..78218d0a02918f94214b169ce15ce6e674b3f5b5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerdi.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerdu.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerdu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6d3b6e4b8412f312993d021beb5b00eab89d0537
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerdu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerip.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerip.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d4e72d6d737b889f27745ae9d55209cdd88c10ac
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerip.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta1.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..63fe419d2fe74da4fbf017c0a33445e5933a58a1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta10.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e99d73109dde4b12b6824bb774fa158cc3fe6688
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta11.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..57b7d8fd7ef90ba985546a206a8fbdc3a5213bff
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta12.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c30c6baa3b7457bf8e2fa5c4fe5ebb861516c7a5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta13.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..47432ff8725690361295e17043368ff4dd1018af
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta14.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7226d16bb29f2e33ef1f6c259d8ffdc5ff7dca50
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta15.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ae9b1025a49acc8d711f4aeed9c0e1304c7539dd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta16.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6047ea89c422436880fcbc8d062fced99a6ef961
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta2.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9c84d448091c8d55d75d4f80f443bd3b11fe8412
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta3.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c70d05b4d9a108a6c57907a17c74b63b3b4c59a5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta4.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4c55013c5fd5971b3ca19e6f545bf1395b9c7bcd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta5.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0407c56280db717f066b10deaba02a0b58438bd9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta6.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0511d928470e6d05f7fc9ffaa818ea9ce479a38c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta7.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..269726fdd3b388a509cff01a97d23507b4c8ba88
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta8.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..84c834f53f29c6db008e917b151df74a9d8dda4b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrta9.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrta9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cef475159bf4e168e96bde7ab43644f23b183189
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrta9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtab.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtab.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..dc796e5ff6eeba849ed0f58019bebde31884b3b0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtab.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtam.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtam.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6aae673153d6635b6cb127aade6febfe70a84d06
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtam.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtbg2.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtbg2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e3e3147af9b1cb61bb693428de214cc47813ee8a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtbg2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtftr.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtftr.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fa63f77562907ddcc1e8aa4dac7171b6853c11ac
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtftr.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto1.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..616903d7d75488946ccbbe323ae24c85b4b01c7e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto10.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a746cb141f626e2087a74b24eab7fda853097bd0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto11.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..10775f2db6fc2abfff4ee19940542abc8d7961f7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto12.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..690c92235d25a5a2ff6b787369481d76ca81c95a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto13.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6a34807bae1f58c2595c1059986da02fe4b08f6e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto14.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0788f3c0838474dee79e2c72c6a9b0f0f84f7308
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto15.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..47d0e8f7d0bca2f5a7d7aa48c65f754308ada9e7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto16.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..85ce53ce7c24eb8a600546a3a87150460ddae73f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto2.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1b9c5ce10ba6b1b526e8c98fe9402fbcd2f1b11d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto3.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1efc16cfe8878a706e7c412b2e7191545f24b4d2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto4.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..216fab90eaea244659c4864f1bbab5ffd1eb4447
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto5.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d1f394d4e14e0769c044989a5598a7c8f752dab5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto6.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7822224d06e1601915f37b6fdf171de90fccbf1d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto7.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9df512e312134e0518506cf19b9c074b4cec7ba4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto8.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4463047ce777364e0a6c8f3c1612edb46b8f2faf
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrto9.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrto9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1f77649156fa7496a3a8e7dfa013c8e8ea703c9c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrto9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtrf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtrf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..26b7c895d5cf8788a464134d04467810a4ed9418
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtrf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtrwt.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtrwt.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9c6562038569c599864d6769b880e50081c6f9b6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtrwt.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoerrtwn.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoerrtwn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..fef6e9314c7dd0bda61987d2e17fffd1bf35d215
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoerrtwn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoesat.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoesat.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..dbb84fe9e078488b53d4e8ecccbf28230d33ba3c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoesat.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoesw.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoesw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..64063ec247f675afb11d817292447ac6d459de41
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoesw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoethf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoethf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..577bb09f5032e70a76143476ac57443e1d6a8540
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoethf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoetluc.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoetluc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3fb579bcb238671b883d1ce99f6391d5ec7435b6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoetluc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoevdf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoevdf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b4f97bf6321412bd823198e2a37dc66ab74927f3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoevdf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoevdfs.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoevdfs.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c171493fba643f69b7ca490f917d6d3a2bfe1e01
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoevdfs.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoeveg.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoeveg.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5b8dd320f146c6d7c9f648d3f0d56b3501e4972d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoeveg.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yoewcou.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yoewcou.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f910b5c7e4b25a4dc9891544ce5907f598162618
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yoewcou.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yomcst.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yomcst.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..db313ae14ffd4f8b5692a71b8ebc6bc9bafdc439
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yomcst.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yomlun.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yomlun.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e2766c08bef1942003078c81f7638fd4c27e39b3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yomlun.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1/yomrip.F90.gz b/MAR/code_mar/radCEP.d/module.d_1/yomrip.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..97629e6ec2265604b73613d05c1d7f8dc16c7c1f
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1/yomrip.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parcli.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parcli.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3ff801eb191cf29ea1f5d22ee9f694955f731f03
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parcli.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parclimf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parclimf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c2230f323dc678ae4a1321e57a655a570ad2a2d1
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parclimf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parcma.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parcma.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7adb7c43410fd9aa8dfa38781f2d0abd4e6801c4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parcma.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pardim.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pardim.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..876223c2eb39b6edfcc407acf2791fd71bfbd26e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pardim.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pardimo.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pardimo.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..43046c3dbbf727cbee288454e6078edb4e00e712
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pardimo.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parerob.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parerob.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6dafb380717ca989b6027557310e71ce812ad642
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parerob.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parfpos.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parfpos.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6d58e2c02e8d5ca6b08bb93afaa187200c527eb2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parfpos.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pargc5.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pargc5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c751222f69c257f297d13f040ddce66eeebb4747
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/pargc5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parptrs.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parptrs.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3abed1572940309d67c876f24f15738d7d7421a2
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parptrs.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrint.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrint.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3c76484a16766a978e4317c304d8cc85e83ed56b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrint.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrrtm.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrrtm.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..75c1e0e0702cb7456e397982b32a6aa758e440cd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrrtm.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrrtm.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrrtm.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2f817a63b6c1ee0a6788a3ee2796ad828cca8b63
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrrtm.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrtm1d.F90.ORIGINAL.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrtm1d.F90.ORIGINAL.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8c4af57146a8317325775590558917b6cf97764a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrtm1d.F90.ORIGINAL.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrtm1d.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrtm1d.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1b754fb2b3fcde30080a930a6099063575f0adcb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/parrtm1d.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/script.bash.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/script.bash.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0a58c95707f3f4dba500c705bfdbf9766b67c9d5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/script.bash.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaer.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaer.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..366f49c0c31bcfebed3f20daeb8278bd2928d924
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaer.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaerc.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaerc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..89c8d591ec9861f0d02ce0eee2c98339f3ed4138
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaerc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaerd.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaerd.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..792a214a42f4beb133583f38b257761b7273e221
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeaerd.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeast.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeast.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..35de9724ba7bf062e0e8561439309d98571ecb37
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeast.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoecld.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoecld.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..927c474ef4bc21bdda7b3e100f8b2836ec33052c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoecld.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoecldp.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoecldp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9948118e3bd53f334c0f204ad7ed211d9e151f18
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoecldp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeclop.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeclop.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..db89e80c8c3baa7b248a3dae7293e876b36e4790
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeclop.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoedbug.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoedbug.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a9ab1a2ff4608f1f91a41df12e2c2c41ac59c0d4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoedbug.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoelw.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoelw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b688685a9c28fe3faf08fc5eda54e0c3b6332f3e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoelw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoemeth.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoemeth.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6acf76a6f5fb62e9d291c3605e3cfd113d6dcc14
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoemeth.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoencst.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoencst.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b1cf15c41b5a08ea07f151261ab305b01793fbf0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoencst.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeolw.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeolw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0ddfe0be0f68b86cfb5df0aea04bfdf117c053e9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeolw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeovlp.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeovlp.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cdf9f6ba190c14ff919bf172b7f900d0c80b8464
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeovlp.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeozoc.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeozoc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a8d1aa76a42d200a96e81286c0e2ee8f27e83249
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeozoc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoephli.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoephli.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..afe2783b87be7cef63f64543a706584ac96063d7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoephli.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoephy.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoephy.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..4ca3b1fd1ec6237e9febc77f4cf28236bfb6e528
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoephy.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerad.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerad.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c495844fd8091329bdef7fa59eb20bc274d6abe5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerad.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerdi.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerdi.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..58f3fc644d7a29e1ece346bfa5e2583640a65988
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerdi.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerdu.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerdu.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a58e6aa634904ef7f5736183e63fa3d8a2c45567
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerdu.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerip.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerip.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8a2daa4be6e9c19e3ff6b29ab84496db48c0efef
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerip.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta1.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..546e262d62b301a4c4fbfdea2a36fb5cb53ab6bb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta10.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..975e00e9a0a47563535a6daaf274f6a71fa4e73e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta11.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2ab35396691f39e5db7992d3d20ba1e2f3bb0ec5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta12.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ea140c9766dfa837588182771009570b9fe8bbe0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta13.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..cc17e7faa6e037918232a812b95d2d75bba3a6d4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta14.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0be444d685c1c70fe1cbd97b5fb427a106dfaad0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta15.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0623f4c72a4a361bee5b57c58b8e6af77d8054a3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta16.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7e2bd70900f488fed972e86ff15577ace95fbcac
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta2.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..ac6712a34c2f23e6630bd1d290cdfd8d7f892ffe
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta3.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8101c378e402db8b5fd262bce830ae5b1d2c9002
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta4.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e1dc29111f8b0e233bb9fd9e345fc0fccc3e378a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta5.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..1307bfac9bcc8d9f7c02312c178b3ea5124cbfc3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta6.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..420351efa89f022384afb37da45a9ac4c0cf8664
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta7.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..845b0359a1a2b8b16e03d48ab9ec488da8d082f3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta8.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..43b99121a3c76ec022a1c4229ed2a76709851f18
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta9.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..994356a29d6dd9879438d1738d1b2ea1a75ef1d0
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrta9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtab.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtab.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..bd54e0956baf2e0e69927bda7b5680c7db72682d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtab.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtam.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtam.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..c84bd7897b0f0ad29a10810813c5deaad85da779
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtam.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtbg2.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtbg2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..a56d2202782b87f0cf3f9191dbae9345204372f8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtbg2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtftr.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtftr.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d591700b3745c32570551ef26fe985725172434d
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtftr.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto1.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto1.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9c216e213a3c06d0fea9b3b7633ff0c4c0f68fa4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto1.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto10.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto10.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..f2f4e98b3cd0e70a1e529482a5a1f10178336173
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto10.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto11.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto11.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..eadcd6c4a3bbbfc064a94f7d978a520871f03301
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto11.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto12.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto12.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..9aa001d14f35bbe2e2f88655504b02481205cc8e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto12.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto13.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto13.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6ede3d58ef9f9f1f23cc4fa5080ef3c0588c64f8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto13.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto14.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto14.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7ee60e2bd95bb376c0ad98322869fb2632361ad7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto14.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto15.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto15.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..52e298586ecfe99b953c4ed59cdd5c026681faa6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto15.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto16.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto16.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..02ca1f49aca569f40cd12b310cc71805340265d3
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto16.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto2.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto2.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b8008c0145cb1787f972d4d5af570bde0bf741dc
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto2.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto3.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto3.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..52087602a9f0fb5820510a1703fa83a27dc07842
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto3.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto4.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto4.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..dba7b0ef7d0db4f9a3d23d38b57e09b5bdc73fe8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto4.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto5.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto5.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8c5673fbbfc7a11924941ad04b68ab4d4c7062c4
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto5.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto6.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto6.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..98283c6e1ae181079575064837612855459dba86
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto6.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto7.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto7.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..63a9a669fccd86ccf445a9e42866c3cf3e37afec
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto7.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto8.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto8.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d7c63501e2896d7dac86bac99e5733509cfc2117
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto8.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto9.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto9.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..0840cd6b5af64f4c7ee510778ce5622d650d6ab7
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrto9.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtrf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtrf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..efd211f3304dd3d7fcfc686f569171e6ca3bb9bd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtrf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtrwt.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtrwt.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..5da3bca260215c591b73e1c8597566e2a563d4bd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtrwt.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtwn.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtwn.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b4a5cdfd00f0be5605e423197eb86919baeb3a1a
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoerrtwn.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoesat.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoesat.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..14e39267c9181d23c9430e08788d4a29f07c1b32
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoesat.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoesw.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoesw.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..81b22611e4e5a511f001255fd4a7dda50ca4a290
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoesw.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoethf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoethf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..8135703212b19fa31b39a6b50c4e6fff6e171458
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoethf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoetluc.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoetluc.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..3fb579bcb238671b883d1ce99f6391d5ec7435b6
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoetluc.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoevdf.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoevdf.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..05d8241d9cd5219018e0c2d863e25f421044c2eb
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoevdf.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoevdfs.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoevdfs.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..743017889f66c803e033aaf884403311e18b9db9
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoevdfs.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeveg.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeveg.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..2ec5330d0f679606f42d3c492dd441eae8bbee0c
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoeveg.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoewcou.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoewcou.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..e089e555ebdc2926f1ba5e6722efeb0f7f2db721
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yoewcou.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomcst.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomcst.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..b61baf7d2b8d6a9d78f9a191ed5ab4dfa7cb55cd
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomcst.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomlun.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomlun.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..d151ab2fa12669dedead62b199003bc3683031d8
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomlun.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomrip.F90.gz b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomrip.F90.gz
new file mode 100644
index 0000000000000000000000000000000000000000..df1e79aa82898f1e9b3f76f6bb0101467c1cdc5b
Binary files /dev/null and b/MAR/code_mar/radCEP.d/module.d_1_no_OMP/yomrip.F90.gz differ
diff --git a/MAR/code_mar/radCEP.d/radCEP.README.gz b/MAR/code_mar/radCEP.d/radCEP.README.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7b25e6a58f8802e9a13cb6db02cfea7da6fe4af5
Binary files /dev/null and b/MAR/code_mar/radCEP.d/radCEP.README.gz differ
diff --git a/MAR/code_mar/radCEP.d/radCEP.bash.gz b/MAR/code_mar/radCEP.d/radCEP.bash.gz
new file mode 100644
index 0000000000000000000000000000000000000000..84110fae489dad9906400ffdb49ccac1f14ee12e
Binary files /dev/null and b/MAR/code_mar/radCEP.d/radCEP.bash.gz differ
diff --git a/MAR/code_mar/radcep_mod.f90 b/MAR/code_mar/radcep_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..db2629288fcd1e4ae05faf83637421dabdc5af03
--- /dev/null
+++ b/MAR/code_mar/radcep_mod.f90
@@ -0,0 +1,30 @@
+module radcep
+ use mardim
+ implicit none
+ integer, parameter :: klonr = 1
+ integer, parameter :: klevr = mz
+ integer, parameter :: nn_aer = 6
+ character(len=6), save :: CMIP_scenario
+
+ real, save, allocatable :: Ae_MAR(:, :, :, :)
+ real, save, allocatable :: O3_MAR(:, :, :)
+
+ logical :: RADini = .false.
+ logical :: RADin2 = .false.
+ common / c_RADini / RADini, RADin2
+ !$OMP threadprivate( /c_RADini/)
+ save
+
+contains
+
+ subroutine radcep_init()
+
+ use mardim, only: mx, my, mz
+ implicit none
+
+ allocate(Ae_MAR(mx, my, nn_aer, mz))
+ allocate(O3_MAR(mx, my, mz))
+
+ endsubroutine radcep_init
+
+endmodule radcep
diff --git a/MAR/code_mar/sbcnew.f90 b/MAR/code_mar/sbcnew.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c2f6931956d58edc22ae1e5d96a38192a56badfd
--- /dev/null
+++ b/MAR/code_mar/sbcnew.f90
@@ -0,0 +1,2947 @@
+#include "MAR_pp.def"
+subroutine sbcnew
+ ! +------------------------------------------------------------------------+
+ ! | MAR SURFACE XF 29-09-2021 MAR |
+ ! | subroutine sbcnew for Greenland/Svalbard 3D simulation |
+ ! | |
+ ! | Simulation GRD |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mar_ib
+ use mardsv
+
+ implicit none
+
+ integer i, j, k, m
+ character * 10 TypeGL
+
+ character*5 :: RCP_CMIP5
+ common / c_RCP_CMIP5 / RCP_CMIP5
+ integer n, l, nbr
+ real ro_old, minuONE
+
+ ! 1) Name of simulation
+ ! =====================
+
+ TypeGL = 'ERR'
+#if(GR)
+ TypeGL = 'GR'
+#endif
+#if(AC)
+ TypeGL = 'AN'
+#endif
+
+ if(TypeGL(1:2) == "AN") then
+ if(mx == 352 .and. my == 300) TypeGL = 'AN20km'
+ if(mx == 201 .and. my == 171) TypeGL = 'AN35km'
+ if(mx == 216 .and. my == 222) TypeGL = 'AN35km'
+ if(mx == 176 .and. my == 148) TypeGL = 'AN35km'
+ if(mx == 141 .and. my == 120) TypeGL = 'AN50km'
+ if(mx == 176 .and. my == 148) TypeGL = 'AN35km'
+ if(len(TypeGL) == 2) then
+ print *, "Domain AN not defined in sbcnew.f"
+ stop
+ endif
+ endif
+
+ if(TypeGL(1:2) == "GR") then
+ if(mx == 60 .and. my == 95) TypeGL = 'GRini' ! MAR tests
+ if(mx == 215 .and. my == 390) TypeGL = 'GR7_5km'
+ if(mx == 250 .and. my == 200) TypeGL = 'GR6km' ! Russian Island
+ if(mx == 165 .and. my == 300) TypeGL = 'GR10km'
+ if(mx == 306 .and. my == 312) TypeGL = 'GR11km'
+ if(mx == 140 .and. my == 250) TypeGL = 'GR12_5km' ! Greenland
+ if(mx == 240 .and. my == 270) TypeGL = 'GR12_5km' ! Greenland + Arctic
+ if(mx == 115 .and. my == 210) TypeGL = 'GR15km'
+ if(mx == 210 .and. my == 230) TypeGL = 'GR15km' ! Greenland + Arctic
+ if(mx == 119 .and. my == 209) TypeGL = 'GR15km'
+ if(mx == 95 .and. my == 165) TypeGL = 'GR20km'
+ if(mx == 96 .and. my == 165) TypeGL = 'GR20km'
+ if(mx == 80 .and. my == 135) TypeGL = 'GR25km'
+ if(mx == 100 .and. my == 150) TypeGL = 'GR25km'
+ if(mx == 68 .and. my == 118) TypeGL = 'GR30km'
+ if(mx == 65 .and. my == 110) TypeGL = 'GR32_5km'
+ if(mx == 60 .and. my == 100) TypeGL = 'GR35km'
+ if(mx == 55 .and. my == 95) TypeGL = 'GR37_5km'
+ if(mx == 60 .and. my == 80) TypeGL = 'GR50km'
+ if(mx == 60 .and. my == 70) TypeGL = 'AC75km'
+ if(mx == 85 .and. my == 95) TypeGL = 'SVa' ! Svalbard
+ if(trim(TypeGL) == "GR") then
+ print *, "Domain GR not defined in sbcnew.f"
+ stop
+ endif
+ endif
+
+ ! 2) inisnow
+ ! ==========
+ if(TypeGL(1:2) == "GR" .or. TypeGL(1:2) == "AN") then
+ if(itexpe == 0) call inisnow(TypeGL)
+ if(itexpe <= 10) then
+ n = 1
+ do i = 1, mx; do j = 1, my
+ if(mskSNo(i, j, n) > 0) then
+ do k = 1, nssSNo(i, j, n)
+ ro_old = rosSNo(i, j, n, k)
+ if(rosSNo(i, j, n, k) <= 300 .and. rosSNo(i, j, n, k) >= 100) then
+ rosSNo(i, j, n, k) = 300.
+ endif
+ if(rosSNo(i, j, n, 1) >= 800 .and. rosSNo(i, j, n, k) >= 800) then
+ ! warning, might be wrong for Antarctica
+ ! todo : check for Antarctica
+ tisSNo(i, j, n, k) = max(273.15 - 20, tisSNo(i, j, n, k))
+ endif
+ if(ro_old /= rosSNo(i, j, n, k)) then
+ dzsSNo(i, j, n, k) = dzsSNo(i, j, n, k) / rosSNo(i, j, n, k) * ro_old
+ print *, "acc", i, j, k, ro_old, rosSNo(i, j, n, k)
+ endif
+ enddo
+ endif
+ enddo;
+ enddo
+ do l = 1, 10
+ call UPDsnow
+ enddo
+ endif
+ endif
+
+ ! 3) UPDsnow
+ ! ==========
+ if(TypeGL(1:2) == "GR" .or. TypeGL(1:2) == "AN") then
+ if(iterun <= 20 .and. jdarGE == 1) call UPDsnow
+ endif
+
+ ! 4) srfsnow
+ ! ==========
+ ! srfsnow read a file to impose a constant snow density
+ if(iterun == 0) call srfsnow(.false., TypeGL)
+
+ ! 5) OUTone
+ ! =========
+ if(TypeGL(1:2) == "AN") then
+ minuONE = minuGE + jsecGE / 60.
+ if((minuONE >= 0 .and. minuONE < 0 + dt / 60.) .or. &
+ (minuONE >= 5 .and. minuONE < 5 + dt / 60.) .or. &
+ (minuONE >= 10 .and. minuONE < 10 + dt / 60.) .or. &
+ (minuONE >= 15 .and. minuONE < 15 + dt / 60.) .or. &
+ (minuONE >= 20 .and. minuONE < 20 + dt / 60.) .or. &
+ (minuONE >= 25 .and. minuONE < 25 + dt / 60.) .or. &
+ (minuONE >= 30 .and. minuONE < 30 + dt / 60.) .or. &
+ (minuONE >= 35 .and. minuONE < 35 + dt / 60.) .or. &
+ (minuONE >= 40 .and. minuONE < 40 + dt / 60.) .or. &
+ (minuONE >= 45 .and. minuONE < 45 + dt / 60.) .or. &
+ (minuONE >= 50 .and. minuONE < 50 + dt / 60.) .or. &
+ (minuONE >= 55 .and. minuONE < 55 + dt / 60.)) then
+ call OUTone(TypeGL, 5)
+ endif
+ endif
+
+ ! 6) OUTsta
+ ! =========
+ ! if(iterun>=1)then
+ ! call OUTsta('066','058', 1)
+ ! call OUTsta('063','053', 2)
+ ! end if
+
+ ! 7) ASSsnow
+ ! ==========
+ ! if (mmarGE>4.and.mmarGE<10) call ASSsnow
+
+ return
+endsubroutine sbcnew
+
+subroutine srfsnow(constantDensity, TypeGL)
+ use mardim
+ use mar_sv
+ use marssn
+ use mar_ge
+ implicit none
+
+ logical, intent(in) :: constantDensity
+ character*10, intent(in) :: TypeGL
+ ! +-- Local Variables
+ ! + ===============
+ real ro_srf(mx, my)
+ character * 100 filein
+ character * 3 mxc, myc
+ logical file_exists
+
+ write(6, 150) jdarGE, mmarGE, iyrrGE, trim(TypeGL(1:7)), mx, my
+150 format(' srfsnow at ', i2, '-', i2, '-', i4, ':', &
+ ' type=', a7, ' mx=', i4, ' my=', i4)
+ if(constantDensity) then
+ if(TypeGL(1:2) == "AN") then
+ write(mxc, '(i3)') mx
+ if(mx < 100) write(mxc, '(i2)') mx
+ write(myc, '(i3)') my
+ if(my < 100) write(myc, '(i2)') my
+ ! MARini in ~/MAR/usr/ produced with compute_MARini-AN.jnl
+ filein = 'MARini-'//trim(TypeGL)//'-'// &
+ trim(mxc)//'x'//trim(myc)//'.cdf'
+ inquire(file=trim(filein), exist=file_exists)
+ if(file_exists) then
+ write(6, *) 'srfsnow, Reading ', TRIM(filein)
+ write(6, *) "RHOSINI"
+ call CF_READ3D(TRIM(filein), 'RHOSINI', 1, mx, my, 1, ro_srf)
+ ! ! conversion 0-1 m to fresh snow : 5% less dense
+ ro_srf = ro_srf * 0.95
+ else
+ write(6, *) " ERROR: ", trim(filein), " does not exist"
+ write(6, *) " >> Use ~/MAR/usr/compute_MARini-AN.jnl"
+ write(6, *) " or set constantDensity=.false. in sbcnew"
+ ! stop
+ endif
+ else
+ print *, " not for ", trim(TypeGL), ", only for Ant. (AN)"
+ ro_srf = -999.
+ endif
+ else
+ ro_srf = -999.
+ endif
+
+endsubroutine srfsnow
+
+subroutine ice_sheet_model_coupling
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mar_ib
+ use mardsv
+
+ implicit none
+
+ integer, parameter :: mxx1 = 60 ! 25km
+ integer, parameter :: myy1 = 110 ! 25km
+ integer, parameter :: xx1 = 9 ! 25km
+ integer, parameter :: yy1 = 17 ! 25km
+
+ ! integer ,parameter :: mxx1 = 51 ! 30km
+ ! integer ,parameter :: myy1 = 93 ! 30km
+ ! integer ,parameter :: xx1 = 9 ! 30km
+ ! integer ,parameter :: yy1 = 16 ! 30km
+
+ ! integer ,parameter :: mxx1 = 42 ! 35km
+ ! integer ,parameter :: myy1 = 78 ! 35km
+ ! integer ,parameter :: xx1 = 9 ! 35km
+ ! integer ,parameter :: yy1 = 15 ! 35km
+
+ real, parameter :: convrd = 180.0 / 3.141592 ! rad => deg
+ real, parameter :: convhd = 15.0 ! hour => deg
+
+ real tmp1(mxx1, myy1), file_OK
+ real lat1(mx, my), lon1(mx, my), bed(mx, my)
+ real newmsk(mx, my), newsh(mx, my), oldsh(mx, my), oldmsk(mx, my)
+
+ integer i, j
+ character * 100 file_name
+
+ logical file_exists
+
+ file_name = "GRISLI4MAR.cdf"
+
+ open(unit=10, file="MARscenario.ctr", status="old", err=1000)
+ rewind 10
+ read(10, *, end=1001)
+ read(10, *, end=1001)
+ read(10, '(a100)', end=1001) file_name
+1000 continue
+1001 continue
+ close(10)
+
+ INQUIRE(FILE=trim(file_name), EXIST=file_exists)
+
+ if(file_exists) then
+
+ write(6, 12) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE
+12 format('XF WARNING: call of ice_sheet_model_coupling: ', i5, 4i3)
+
+ write(*, *) "WARNING: itexpe must be an integer*8 in MARCTR.inc"
+
+ lon1 = 0; lat1 = 0; bed = 0; newsh = 0; newmsk = 0
+
+ call CF_READ2D(trim(file_name), 'LON', 1, mxx1, myy1, 1, tmp1)
+ do i = 1, mxx1; do j = 1, myy1
+ lon1(i + xx1, j + yy1) = tmp1(i, j)
+ enddo;
+ enddo
+
+ call CF_READ2D(trim(file_name), 'LAT', 1, mxx1, myy1, 1, tmp1)
+ do i = 1, mxx1; do j = 1, myy1
+ lat1(i + xx1, j + yy1) = tmp1(i, j)
+ enddo;
+ enddo
+
+ call CF_READ2D(trim(file_name), 'BED', 1, mxx1, myy1, 1, tmp1)
+ do i = 1, mxx1; do j = 1, myy1
+ bed(i + xx1, j + yy1) = tmp1(i, j)
+ enddo;
+ enddo
+
+ call CF_READ2D(trim(file_name), 'newSH', 1, mxx1, myy1, 1, tmp1)
+ do i = 1, mxx1; do j = 1, myy1
+ newsh(i + xx1, j + yy1) = tmp1(i, j)
+ enddo;
+ enddo
+
+ call CF_READ2D(trim(file_name), 'newMSK', 1, mxx1, myy1, 1, tmp1)
+ do i = 1, mxx1; do j = 1, myy1
+ newmsk(i + xx1, j + yy1) = tmp1(i, j)
+ enddo;
+ enddo
+
+ oldmsk = mskSNo(:, :, 1)
+ oldsh = sh
+
+ do i = 1, mx; do j = 1, my
+
+ if(newmsk(i, j) > 0) then
+
+ ! !SH
+ if(abs(newsh(i, j) - sh(i, j)) > 0.1) then
+
+ sh(i, j) = newsh(i, j)
+ sh(i, j) = max(sh(i, j), bed(i, j))
+
+ write(6, 13) i, j, oldsh(i, j), sh(i, j)
+13 format(2i4, " ice sheet SH:", f7.1, '=>', f7.1)
+ endif
+
+ ! ! MSK
+ if(mskSNo(i, j, 1) > 0 .and. mskSNo(i, j, 1) < 100 .and. &
+ abs(lon1(i, j) - GElonh(i, j) * convhd) < 0.01 .and. &
+ abs(lat1(i, j) - GElatr(i, j) * convrd) < 0.01 .and. &
+ abs(newmsk(i, j) - mskSNo(i, j, 1)) > 0.01) then
+
+ mskSNo(i, j, 1) = newmsk(i, j)
+ mskSNo(i, j, 1) = max(0.001, mskSNo(i, j, 1))
+ mskSNo(i, j, 1) = min(99.999, mskSNo(i, j, 1))
+
+ ifraTV(i, j, 1) = mskSNo(i, j, 1)
+ ifraTV(i, j, 2) = 100.-mskSNo(i, j, 1)
+
+ SLsrfl(i, j, 1) = mskSNo(i, j, 1) / 100.
+ SLsrfl(i, j, 2) = 1.-mskSNo(i, j, 1) / 100.
+
+ write(6, 14) i, j, oldmsk(i, j), mskSNo(i, j, 1)
+14 format(2i4, " ice sheet MSK:", f7.2, '=>', f7.2)
+ endif
+
+ endif
+
+ enddo;
+ enddo
+ ! else
+ ! print *, trim(file_name) // " not found"
+ endif
+
+endsubroutine ice_sheet_model_coupling
+
+subroutine ASSsnow
+ ! +------------------------------------------------------------------------+
+ ! | MAR SURFACE XF MAR |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mar_ib
+ implicit none
+ ! +
+ ! +--General Variables
+ ! + =================
+
+ ! +--Local Variables
+ ! + =================
+
+ real, parameter :: melt_thrsd = 8.5 ! mmWE/day
+ real, parameter :: dzsn_thrsd = 0.05 ! m
+
+ integer :: i, j, k
+ integer :: day, day_1st_may, day_current, kksn, n
+ integer :: ASS_up, ASS_do
+
+ character*20 :: filename
+ character*4 :: YYYYc
+
+ real :: melt_current, thrsd, dz, dzsn
+
+ real :: tmp1(60, 112), tmp2(60, 112)
+ real :: msk_sat(mx, my), melt_sat(mx, my)
+
+ ! + SMMR/SSMI data set reading
+
+ day_1st_may = 122 - min(1, mod(iyrrGE, 4))
+
+ day_current = njyrGE(mmarGE) + &
+ njybGE(mmarGE) * max(0, 1 - mod(iyrrGE, 4)) + jdarGE
+
+ day = day_current - day_1st_may + 1
+
+ write(YYYYc, '(i4)') iyrrGE
+
+ msk_sat = 0; melt_sat = 1
+
+ filename = 'MELT_'//YYYYc//'.nc'
+
+ call CF_READ2D(filename, 'MSK_SAT', 1, 60, 112, 1, tmp1)
+ do i = 1, 60; do j = 1, 112
+ msk_sat(i + 9, j + 20) = tmp1(i, j)
+ enddo;
+ enddo
+
+ call CF_READ2D(filename, 'MELT02', day, 60, 112, 1, tmp1)
+ call CF_READ2D(filename, 'MELT02', min(153, day + 1), 60, 112, 1, tmp2)
+ do i = 1, 60; do j = 1, 112
+ if(tmp1(i, j) == 0) melt_sat(i + 9, j + 20) = 1
+ if(tmp1(i, j) == 1) melt_sat(i + 9, j + 20) = 2
+ if(tmp1(i, j) == tmp2(i, j) .and. tmp1(i, j) == 1) melt_sat(i + 9, j + 20) = 3
+ if(tmp1(i, j) == tmp2(i, j) .and. tmp1(i, j) == 0) melt_sat(i + 9, j + 20) = 0
+ enddo;
+ enddo
+
+ do i = 1, mx; do j = 1, my; n = 1
+ if(mskSNo(i, j, 1) >= 90 .and. msk_sat(i, j) >= 3) then
+
+ melt_current = -1 * (wem_IB(i, j, n) - wem0IB(i, j, n))
+
+ dzsn = 0; k = nssSNo(i, j, n) + 1
+ do while(dzsn <= dzsn_thrsd .or. k > nssSNo(i, j, n) - 2)
+ k = k - 1
+ dzsn = dzsn + dzsSNo(i, j, n, k)
+ kksn = k
+ enddo
+
+ ! ! 15hTU = midday
+
+ ASS_up = 0
+ ASS_do = 0
+
+ do k = 1, 3
+ if(melt_sat(i, j) <= 1 .and. &
+ melt_current >= 1.1 * melt_thrsd * (3.+2.*real(k)) / 10. .and. &
+ jhurGE <= 15 + (k - 1) * 5) then
+ ASS_up = k
+ thrsd = melt_thrsd * (3.+2.*real(k)) / 10.
+ endif
+ enddo ! 15h => 5/10 ; 20h => 7/10 ; 25h => 9/10
+
+ if(melt_sat(i, j) <= 1 .and. melt_current > melt_thrsd) ASS_up = 0
+
+ do k = 1, 4
+ if(melt_sat(i, j) >= 2 .and. &
+ melt_current <= 0.9 * melt_thrsd * real(k) / 4. .and. &
+ jhurGE >= 15 + k * 2) then
+ ASS_do = k
+ thrsd = melt_thrsd * real(k) / 4.
+ endif
+ enddo ! 17h => 1/4 ; 19h => 2/4 ; 21h => 3/4 ; 23h => 4/4
+
+ if(ASS_up >= 1) then
+
+ dz = 0
+ do k = nssSNo(i, j, n), kksn, -1
+
+ tisSNo(i, j, n, k) = min(tisSNo(i, j, n, k), &
+ 273.15 - (dzsn - dz) / dzsn)
+ dz = dzsSNo(i, j, n, k) + dz
+
+ enddo
+
+ write(*, *) ' '
+ write(*, 11) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, i, j, &
+ melt_current, melt_thrsd, ASS_up
+11 format(' ASSsnow (up) at', i5, 4i3, &
+ ' for (', i3, ','i3, ') : ', f5.2, '>', f6.2, i2)
+ write(*, *) ' '
+
+ endif
+
+ if(ASS_do >= 1) then
+
+ dz = 0
+ do k = nssSNo(i, j, n), kksn, -1
+
+ tisSNo(i, j, n, k) = 273.15 + (dzsn - dz) / dzsn
+ dz = dzsSNo(i, j, n, k) + dz
+
+ enddo
+
+ write(*, *) ' '
+ write(*, 12) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, i, j, &
+ melt_current, melt_thrsd, ASS_do
+12 format(' ASSsnow (down) at', i5, 4i3, &
+ ' for (', i3, ','i3, ') : ', f5.2, '<', f6.2, i2)
+ write(*, *) ' '
+
+ endif
+
+ endif
+ enddo;
+ enddo
+
+endsubroutine ASSsnow
+
+subroutine inisnow(TypeGL)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SURFACE XF |
+ ! | subroutine inisnow initialises the SNOW MODEL |
+ ! | Modified to run with mw = 5 Charlotte Lang 13/03/2015 |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mar_ib
+ use mardsv
+#if(iso)
+ use mariso, only: iso_init_type, rosSNo_iso, wasSNo_iso, SWaSNo_iso, &
+ snohSN_iso, eta_TV_iso
+#endif
+ implicit none
+
+ ! +--Local Variables
+ ! + ===============
+ ! snow profiles compatible with SISVAT_zSn snow discretization splitting/agregation
+ ! Profil_15_30m : 29.7 m in 15 layer
+ real, parameter :: Profil_15_30m(15) = (/0.01, 0.01, 0.03, 0.04, 0.05, 0.26, 0.6, 1., &
+ 1.60, 2.30, 3.00, 3.70, 4.70, 5.70, 6.70/)
+ ! Profil_10 : 1 m in 10 layers
+ real, parameter :: Profil_10(10) = (/0.005, 0.01, 0.02, 0.03, 0.04, 0.05, 0.075, 0.10, 0.25, 0.42/)
+ ! Profil_15 : 1 m in 15 layers
+ real, parameter :: Profil_15(15) = (/0.005, 0.01, 0.015, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, &
+ 0.08, 0.09, 0.1, 0.12, 0.14, 0.17/)
+ real, parameter :: profil_29_20m(29) = (/0.004, 0.004, 0.005, 0.006, 0.008, 0.011, &
+ 0.016, 0.022, 0.03, 0.04, 0.053, 0.069, 0.089, &
+ 0.114, 0.144, 0.182, 0.228, 0.286, 0.358, &
+ 0.45, 0.56, 0.71, 0.90, 1.15, 1.48, 1.92, 2.5, &
+ 3.34, 5.321/)
+ ! from C Agosta but bottom layer corrected to reach 20m (from 4.5 to 5.321)
+ ! dz_min : theoritical snow discretization dz_min*i^2 as in SISVAT_zSn
+ real, parameter :: dz_min = 0.005
+
+ real depth, ela
+ real ini_snow(mx, my), ann_temp(mx, my)
+ real g2s, denss
+ real ice_depth, distup
+ integer nbr_layer
+
+ integer i, j, k
+ integer ni, nj, nk, n, isn
+ integer i_sea, j_sea, i_tundra, j_tundra
+ integer i_dry, j_dry, i_abla, j_abla
+ integer i_perco, j_perco, INI, iveg_13
+
+ real, parameter :: convhd = 15. ! hour => deg
+ real, parameter :: convrd = 180./3.141592 ! rad => deg
+
+ character * 10 TypeGL
+ character * 99 Filename
+ character * 3 mxc, myc
+
+ real ro_ini(mx, my, 10), ti_ini(mx, my, 10)
+ real g1_ini(mx, my, 10), g2_ini(mx, my, 10), zn_ini(mx, my)
+ real tmp1(mx, my)
+
+ real ns1(mx, my)
+ real ni1(mx, my)
+
+ real, allocatable ::snwae(:, :, :)
+ real, allocatable :: znsn(:, :, :)
+ real, allocatable :: ag1(:, :, :)
+ real, allocatable :: dz1(:, :, :)
+ real, allocatable :: nh1(:, :, :)
+ real, allocatable :: g11(:, :, :)
+ real, allocatable :: g21(:, :, :)
+ real, allocatable :: ti1(:, :, :)
+ real, allocatable :: ro1(:, :, :)
+ real, allocatable :: wa1(:, :, :)
+
+ character * 4 iyrrGEc
+
+ ! Antarctica
+ ! ----------
+ !+ Interpolated surface snow density (~/MAR/usr/compute_MARini-AN.jnl)
+ real rosSNo_ini(mx, my), tasSNo_ini(mx, my), smbSNo_ini(mx, my)
+ ! local variables
+ real x0, y0, dh
+ integer ii, jj
+ real ro_i, ro_w, R_gc, E_1, E_2, Ao
+ real dz, ro_up, tas, fe_ro, deltaPa, drhodz
+ logical file_exists
+ logical, parameter :: verboseAntarctica = .true.
+ integer firstPoint
+
+ ! mean_dens : mean surface density [kg/m3]
+ real mean_dens
+ ! mean_temp : mean annual surface temperature [K]
+ real mean_temp
+ real lat_scale, sh_scale, ln_smb, alpha0, alpha1
+ ! C0, C1 : constant, 0.07 for z <= 550 kg m-3
+ real, parameter :: C0 = 0.07
+ real, parameter :: C1 = 0.03
+ ! rho_i : ice density [kg m-3]
+ real, parameter :: rho_ice = 917.
+ ! E_c : activation energy [J mol-1]
+ real, parameter :: E_c = 60000.
+ ! E_g : activation energy [J mol-1]
+ real, parameter :: E_g = 42400.
+ ! R : gas constant [J mol-1 K-1]
+ real, parameter :: R = 8.3144621
+ real E0, E1, z550, rho0, rho1
+ logical reset_snow
+
+ allocate(snwae(mx, my, nsno))
+ allocate(znsn(mx, my, nsno))
+
+ allocate(ag1(mx, my, nsno))
+ allocate(dz1(mx, my, nsno))
+ allocate(nh1(mx, my, nsno))
+ allocate(g11(mx, my, nsno))
+ allocate(g21(mx, my, nsno))
+ allocate(ti1(mx, my, nsno))
+ allocate(ro1(mx, my, nsno))
+ allocate(wa1(mx, my, nsno))
+
+ reset_snow = .true.
+
+ ! +--DATA
+ ! + ====
+
+ ann_temp = tfsnow + 48.38 - (0.007924 * sh) - (0.7512 * (GElatr / degrad))
+
+ ! Mean Climatological Ann. Temperature
+ ag1 = real(jdarGE + njyrGE(mmarGE)) / 365.+iyrrGE
+
+ ! + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ if(nsno < 20) then
+ print *, "inisnow: nsno in mar_sv_mod.f90 should be > 20"
+ print *, " nsno=", nsno
+ stop
+ endif
+
+ if(mw /= 2) then
+ print *, "inisnow: mw in mardim_mod.f90 should be 2"
+ print *, " mw=", mw
+ stop
+ endif
+ ! + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+
+ ! +--TT srf
+ ! + ======
+ do j = 1, my
+ do i = 1, mx
+ tairSL(i, j) = pktaDY(i, j, mz) &
+ * (pstDYn(i, j) + ptopDY)**cap
+ tairSL(i, j) = min(tairDY(i, j, mz), tairSL(i, j))
+ tairSL(i, j) = tairDY(i, j, mz) !+CA+!
+ enddo
+ enddo
+
+ ! +--Mask initialisation
+ ! + ===================
+ iveg_13 = 0
+ do i = 1, mx
+ do j = 1, my
+ if(ivegTV(i, j, 1) == 14 .or. ivegTV(i, j, 1) == -1) then
+ print *, "warning iveg=-1", i, j
+ iveg_13 = 1
+ ivegTV(i, j, 1) = -1
+ endif
+ enddo
+ enddo
+
+ do i = 1, mx
+ do j = 1, my
+ do k = 1, mw
+ mskSNo(i, j, k) = 0
+ ! ifraTV = SFR = NSTsfr
+ if(isolSL(i, j) >= 3 .and. k /= nsx) mskSNo(i, j, k) = ifraTV(i, j, k)
+ if(isolSL(i, j) >= 3 .and. k == nsx) mskSNo(i, j, k) = 0.
+ if(isolSL(i, j) >= 3 .and. iveg_13 == 1) then
+ if(ivegTV(i, j, k) == -1 .and. k == 1) then
+ ivegTV(i, j, k) = 0.
+ mskSNo(i, j, k) = ifraTV(i, j, k)
+ alaiTV(i, j, k) = 0.
+ glf_TV(i, j, k) = 0.
+ else
+ mskSNo(i, j, k) = 0.
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! +--Surface initialisation
+ ! + ======================
+
+ ! 1) Ocean and Sea Ice Points
+ ! ---------------------------
+
+ dzsSNo = 0.; rosSNo = 0.; g1sSNo = 0.; g2sSNo = 0.
+ nhsSNo = 0.; tisSNo = 0.; wasSNo = 0.; agsSNo = 0.
+ nssSNo = 0; nisSNo = 0; issSNo = 0; snohSN = 0.
+ SWaSNo = 0.
+
+ do j = 1, my
+ do i = 1, mx
+ do n = 1, nsx
+ TsrfSL(i, j, n) = tairSL(i, j)
+ TvegTV(i, j, n) = tairSL(i, j)
+ if((isolSL(i, j) < 3)) then
+ i_sea = i
+ j_sea = j
+ isolTV(i, j) = 0
+ SLsrfl(i, j, 1) = 1.
+ ifraTV(i, j, 1) = 100
+ AlbSTV(i, j) = 0.15 ! / 2 in SISVAT
+ ! to not have problem when the ice sea melt
+ do isn = 1, llx
+ TsolTV(i, j, n, isn) = SST_LB(i, j)
+ eta_TV(i, j, n, isn) = 1.
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! 2) Snow zone
+ ! ------------
+ INI = 1
+ write(mxc, '(i3)') mx
+ if(mx < 100) write(mxc, '(i2)') mx
+ write(myc, '(i3)') my
+ if(my < 100) write(myc, '(i2)') my
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if(TypeGL(1:2) == "GR") INI = 2
+ if(TypeGL(1:2) == "SV") INI = 4
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ if(TypeGL(1:5) /= "GRini" .and. ( &
+ TypeGL(1:2) == "GR" .or. &
+ TypeGL == "SV7.5km" .or. TypeGL == "SV5km")) then
+ INI = 3
+ write(iyrrGEc, '(i4)') iyrrGE
+ Filename = 'MARini-'//trim(TypeGL)//'-'// &
+ trim(mxc)//'x'//trim(myc)//'-'// &
+ iyrrGEc//'.cdf'
+ print *, "Read of "//trim(Filename)
+ call CF_READ3D(TRIM(Filename), 'AG1', 1, mx, my, nsno, ag1)
+ call CF_READ3D(TRIM(Filename), 'DZ1', 1, mx, my, nsno, dz1)
+ call CF_READ3D(TRIM(Filename), 'NH1', 1, mx, my, nsno, nh1)
+ call CF_READ3D(TRIM(Filename), 'G11', 1, mx, my, nsno, g11)
+ call CF_READ3D(TRIM(Filename), 'G21', 1, mx, my, nsno, g21)
+ call CF_READ3D(TRIM(Filename), 'TI1', 1, mx, my, nsno, ti1)
+ call CF_READ3D(TRIM(Filename), 'RO1', 1, mx, my, nsno, ro1)
+ call CF_READ3D(TRIM(Filename), 'WA1', 1, mx, my, nsno, wa1)
+ call CF_READ2D(TRIM(Filename), 'NS1', 1, mx, my, 1, ns1)
+ call CF_READ2D(TRIM(Filename), 'NI1', 1, mx, my, 1, ni1)
+ endif
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if(TypeGL(1:2) == "AN") then
+ INI = 5
+ ! reset
+ if(reset_snow) INI = 7
+ ! From old snowfiles
+ write(iyrrGEc, '(i4)') iyrrGE
+ Filename = 'MARini-'//trim(TypeGL)//'-'// &
+ trim(mxc)//'x'//trim(myc)//'-'// &
+ iyrrGEc//'.cdf'
+ inquire(file=trim(Filename), exist=file_exists)
+ if(file_exists) then
+ INI = 6 !CKittel yearly IniSNOW from ANT-35km snow conditions
+ print *, "Read of "//trim(Filename)
+ call CF_READ3D(TRIM(Filename), 'AG1', 1, mx, my, nsno, ag1)
+ call CF_READ3D(TRIM(Filename), 'DZ1', 1, mx, my, nsno, dz1)
+ call CF_READ3D(TRIM(Filename), 'NH1', 1, mx, my, nsno, nh1)
+ call CF_READ3D(TRIM(Filename), 'G11', 1, mx, my, nsno, g11)
+ call CF_READ3D(TRIM(Filename), 'G21', 1, mx, my, nsno, g21)
+ call CF_READ3D(TRIM(Filename), 'TI1', 1, mx, my, nsno, ti1)
+ call CF_READ3D(TRIM(Filename), 'RO1', 1, mx, my, nsno, ro1)
+ call CF_READ3D(TRIM(Filename), 'WA1', 1, mx, my, nsno, wa1)
+ call CF_READ2D(TRIM(Filename), 'NS1', 1, mx, my, 1, ns1)
+ call CF_READ2D(TRIM(Filename), 'NI1', 1, mx, my, 1, ni1)
+ endif
+
+ if(INI == 5) then
+ firstPoint = 0.
+ Filename = 'MARini-'//trim(TypeGL)//'-'// &
+ trim(mxc)//'x'//trim(myc)//'.cdf'
+ inquire(file=trim(Filename), exist=file_exists)
+ if(file_exists) then
+ write(6, *) " Reading ", TRIM(Filename)
+ write(6, *) 'RHOSINI'
+ call CF_READ3D(TRIM(Filename), 'RHOSINI', 1, mx, my, 1, rosSNo_ini)
+ write(6, *) 'STINI'
+ call CF_READ3D(TRIM(Filename), 'STINI', 1, mx, my, 1, tasSNo_ini)
+ write(6, *) 'SMBINI'
+ call CF_READ3D(TRIM(Filename), 'SMBINI', 1, mx, my, 1, smbSNo_ini)
+ write(6, *) " > end reading"
+ smbSNo_ini = max(smbSNo_ini, 20.)
+ else
+ write(6, *) " ERROR: ", trim(Filename), " does not exist"
+ write(6, *) " >> Use ~/MAR/usr/compute_MARini-AN.jnl"
+ stop
+ endif
+ endif
+ endif
+
+ write(6, *)
+ write(6, 150) jdarGE, mmarGE, iyrrGE, trim(TypeGL(1:7)), &
+ mx, my, mz, mw, nsno, INI
+150 format('inisnow at ', i2, '-', i2, '-', i4, ':', &
+ ' type=', a7, ' mx=', i4, ' my=', i4, &
+ ' mz=', i3, ' mw=', i3, ' nsno=', i3, ' INI=', i2)
+ write(6, *)
+
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) >= 3) then
+ if(GElonh(i, j) * convhd > -43) then ! Equilibrium line (m)
+ ELA = -32759.680 + 1001.782 &
+ * GElatr(i, j) * convrd &
+ - 7.331 * GElatr(i, j) * GElatr(i, j) &
+ * convrd * convrd
+ else
+ ELA = -23201.445 + 746.249 &
+ * GElatr(i, j) * convrd &
+ - 5.640 * GElatr(i, j) * GElatr(i, j) &
+ * convrd * convrd
+ endif
+ ELA = max(650., ELA)
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ denss = max(450., 1700.*(1.-(sh(i, j) / (1.5 * ELA))**2))
+ g2s = max(5., 20.*(1.-(sh(i, j) / (1.5 * ELA))**2))
+ ! Svalbard
+ if(INI == 4) then
+ g2s = 3
+ ann_temp(i, j) = 273.15 - 10
+ endif
+
+ ! Antarctica
+ if(INI == 5 .and. GElatr(i, j) < -1.047) then !-1.047 = -60 deg., for large area with Ant + extraland
+ g2s = 3
+ ! mean annual temperature
+ ann_temp(i, j) = tasSNo_ini(i, j)
+ endif
+
+ ! firn density: exp interpollated between 920 and denss
+ ! firn temp : linearly interpollated between TairSL and T annual
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ do n = 1, nsx
+ if(mskSNo(i, j, n) > 0 .and. n /= nsx) then
+ nbr_layer = 15
+ if(INI == 7) nbr_layer = 29 !CK reset
+ else
+ nbr_layer = 0
+ endif
+ nisSNo(i, j, n) = 0.
+ ice_depth = 20.
+ depth = ice_depth
+ if(nbr_layer > 0) then
+ do k = 1, nbr_layer
+ ! ca 4 m in 8 layers of Profil_8
+ if(nbr_layer == 15 .and. ice_depth == 30.) then
+ dzsSNo(i, j, n, k) = Profil_15_30m(nbr_layer - k + 1)
+ else if(nbr_layer == 29 .and. ice_depth == 20.) then
+ ! INI==7, CK from reset Cecile
+ dzsSNo(i, j, n, k) = profil_29_20m(nbr_layer - k + 1)
+ else
+ dzsSNo(i, j, n, k) = max(0.01, &
+ ice_depth * Profil_15(nbr_layer - k + 1))
+ endif
+ depth = depth - dzsSNo(i, j, n, k) / 2. !+CA+!
+ nhsSNo(i, j, n, k) = 0.
+ g1sSNo(i, j, n, k) = 99.
+ g2sSNo(i, j, n, k) = 99.
+ wasSNo(i, j, n, k) = 0.
+ agsSNo(i, j, n, k) = 0.
+ tairSL(i, j) = min(273., tairSL(i, j))
+ distup = min(1., max(0., 1.-depth / ice_depth))
+ tisSNo(i, j, n, k) = ann_temp(i, j) * (1.-distup**2) &
+ + tairSL(i, j) * distup**2
+ rosSNo(i, j, n, k) = denss * (1.-distup**2) &
+ + 300.*distup**2
+ ! Svalbard
+ if(INI == 4) &
+ rosSNo(i, j, n, k) = min(920., max(500., &
+ 500.+(400.-sh(i, j))))
+ ! All
+ if(k >= nbr_layer - 5) &
+ rosSNo(i, j, n, k) = min(250.+50.*(nbr_layer - k), &
+ rosSNo(i, j, n, k))
+ if(rosSNo(i, j, n, k) >= roCdSV + 70) rosSNo(i, j, n, k) = 920
+ if(rosSNo(i, j, n, k) < roCdSV + 70) g2sSNo(i, j, n, k) = g2s
+ ! Greenland
+ if(INI == 2) then
+ rosSNo(i, j, n, k) = ro_ini(i, j, nbr_layer - k + 1)
+ tisSNo(i, j, n, k) = ti_ini(i, j, nbr_layer - k + 1) * (1.-distup**2) &
+ + tairSL(i, j) * distup**2
+ g1sSNo(i, j, n, k) = g1_ini(i, j, nbr_layer - k + 1)
+ g2sSNo(i, j, n, k) = g2_ini(i, j, nbr_layer - k + 1)
+ endif
+ if(INI == 3 .or. INI == 6) tisSNo(i, j, n, k) = ti1(i, j, k)
+
+ ! All
+ rosSNo(i, j, n, k) = max(200., rosSNo(i, j, n, k))
+ rosSNo(i, j, n, k) = min(920., rosSNo(i, j, n, k))
+ tisSNo(i, j, n, k) = min(273., tisSNo(i, j, n, k))
+ depth = depth - dzsSNo(i, j, n, k) / 2.
+ if(rosSNo(i, j, n, k) >= roCdSV + 70) nisSNo(i, j, n) = k
+ enddo ! k = 1,nbr_layer
+ ! Antarctica
+ if(INI == 5 .and. GElatr(i, j) < -1.047) then !
+ if(rosSNo_ini(i, j) == 470) firstPoint = firstPoint + 1
+ if(firstPoint == 1 .and. verboseAntarctica) then
+ print *, "[Ant] snowpack initialization"
+ endif
+ ! surface layer
+ rosSNo(i, j, n, nbr_layer) = rosSNo_ini(i, j)
+ deltaPa = 0.0 + &
+ rosSNo_ini(i, j) * &
+ dzsSNo(i, j, n, nbr_layer) / 2.* &
+ gravit * 1e-6 ! overburden pressure (MPa)
+ ! lower layers
+ if(nbr_layer > 1) then
+ ro_w = 1000 ! water density (kg m-3)
+ ro_i = 917 ! ice density (kg m-3)
+ R_gc = 8.3144621 ! gas constant (J mol-1 K-1)
+ E_1 = 10160 ! activation energy (J mol-1)
+ E_2 = 60000 ! activation energy (J mol-1)
+ Ao = 2.54e4 ! constante (MPa-3 s-1)
+ tas = tasSNo_ini(i, j) ! mean surface temperature (K)
+ do k = nbr_layer - 1, 1, -1
+ ro_up = rosSNo(i, j, n, k + 1)
+ dz = (dzsSNo(i, j, n, k + 1) + dzsSNo(i, j, n, k)) / 2.
+ drhodz = -9999
+ deltaPa = deltaPa + ro_up * dz * gravit * 1.e-6
+ if(firstPoint == 1 .and. verboseAntarctica) then
+ print *, "[Ant] i,j,n,k: ", i, j, n, k
+ endif
+ if(ro_up <= 550.) then
+ ! Ligtenberg (2011) > Barnola (1991)
+ ! drhodz : 11 -> (m-1)
+ drhodz = 11 * ro_up / ro_w * (ro_i - ro_up) * &
+ exp(-E_1 / (R_gc * tas))
+ if(firstPoint == 1 .and. verboseAntarctica) then
+ print *, "[Ant] drdz : ", drhodz
+ print *, "[Ant] drdz 1: ", 11 * ro_up * (ro_i - ro_up)
+ print *, "[Ant] drdz 2: ", E_1 / (R_gc * tas)
+ print *, "[Ant] drdz 3: ", exp(-E_1 / (R_gc * tas))
+ endif
+ else
+ ! Ligtenberg (2011) > Barnola (1991)
+ fe_ro = 10.** &
+ (-37.455 * (ro_up / 1000.)**3 &
+ + 99.743 * (ro_up / 1000.)**2 &
+ - 95.027 * (ro_up / 1000.) &
+ + 30.673)
+ ! drhodz : Ao (MPa-3 s-1); deltaPa (MPa)
+ drhodz = Ao * deltaPa**3 * ro_up / &
+ (smbSNo_ini(i, j) / (365 * 24 * 3600)) * &
+ ro_up * fe_ro * exp(-E_2 / (R_gc * tas))
+ if(firstPoint == 1 .and. verboseAntarctica) then
+ print *, "[Ant] Ao*ro_up: ", Ao * ro_up
+ print *, "[Ant] smb: ", smbSNo_ini(i, j) / (365 * 24 * 3600)
+ print *, "[Ant] fe: ", fe_ro
+ print *, "[Ant] dPa: ", deltaPa
+ print *, "[Ant] ddPa: ", ro_up * dz * gravit * 1e-6
+ print *, "[Ant] exp: ", exp(-E_2 / (R_gc * tas))
+ endif
+ endif ! ro_up<=550.
+ rosSNo(i, j, n, k) = rosSNo(i, j, n, k + 1) + drhodz * dz
+ if(firstPoint == 1 .and. verboseAntarctica) then
+ print *, "[Ant] ro_up: ", ro_up
+ print *, "[Ant] dz: ", dz
+ print *, "[Ant] tas: ", tas
+ print *, "[Ant] drhodz: ", drhodz
+ print *, "[Ant] rosSNo: ", rosSNo(i, j, n, k)
+ endif
+ enddo ! k = nbr_layer-1,1,-1
+ do k = 1, nbr_layer
+ g1sSNo(i, j, n, k) = 99.
+ g2sSNo(i, j, n, k) = g2s
+ rosSNo(i, j, n, k) = max(300., rosSNo(i, j, n, k))
+ rosSNo(i, j, n, k) = min(920., rosSNo(i, j, n, k))
+ if(rosSNo(i, j, n, k) >= roCdSV) nisSNo(i, j, n) = k
+ enddo
+ endif ! nbr_layer>1
+ endif ! INI==5 (Antarctica)
+ endif ! if (nbr_layer> 0 )
+
+ ! Antarctica reset
+ if(INI == 7 .and. GElatr(i, j) < -1.047) then
+ ! initialize mean variables (unrealistic)
+ mean_temp = TfSnow
+ mean_dens = 300.
+ ! loop on grid cells
+ ! approximations for mean_temp and mean_dens
+ ! from Feulner et al., 2013 (DOI: 10.1175/JCLI-D-12-00636.1)
+ ! Fig. 3 and 5 : the lapse rate vs. latitude at high latitude is about 0.55 °C °lat-1
+ ! with a moist-adiabatic lapse rate of 5 °C km-1 everywhere except for Antarctica,
+ ! for Antarctica, a dry-adiabatic lapse rate of 9.8 °C km-1 is assumed.
+
+ ! Antarctica mean temperature : function of altitude and latitude
+ ! for altitudes 0. to 500. m, lat_scale varies from 1.3 to 0.6 °C °lat-1
+ lat_scale = (0.6 - 1.3) / 500.*sh(i, j) + 1.3
+ lat_scale = max(min(lat_scale, 1.3), 0.6)
+ ! for altitudes 0. to 500. m, sh_scale varies from 6.5 to 9.8 °C km-1
+ sh_scale = (9.8 - 6.5) / 500.*sh(i, j) + 6.5
+ sh_scale = max(min(sh_scale, 9.8), 6.5)
+ mean_temp = TfSnow - 7.-sh_scale * sh(i, j) / 1000. &
+ +lat_scale * (GElatr(i, j) * 180./pi + 60.)
+
+ ! Antarctica surface density : function of mean annual temperature
+ ! surface density of 350. kg m-3 at Dome C and 450. kg m-3 at Prud'homme (Agosta et al. 2013)
+ ! 350 kg m-3 is a typical value for the Antarctic plateau around 3200 m.
+ ! Weinhart et al 2020 https://doi.org/10.5194/tc-14-3663-2020 and Sugiyama et al. 2011 oi: 10.3189/2012JoG11J201
+ ! 320 kg m-3 is reached at Dome A, 4100 m a.s.l.
+ ! Dome C : st_ant_param(3233, -75.1) = -47.7
+ ! Dumont d'Urville : st_ant_param(0, -66.66) = -15.7
+ mean_dens = (450.-320.) / (-15.7 + 47.7) * (mean_temp - TfSnow + 15.7) + 450.
+ mean_dens = min(450., max(320., mean_dens))
+
+ depth = ice_depth
+ do k = 1, 29
+ nhsSNo(i, j, n, k) = 0.
+ g1sSNo(i, j, n, k) = 99.
+ g2sSNo(i, j, n, k) = 3.
+ wasSNo(i, j, n, k) = 0.
+ agsSNo(i, j, n, k) = 0.
+ ! distance to surface
+ depth = depth - dzsSNo(i, j, n, k) / 2.
+ distup = min(1., max(0., depth / ice_depth))
+ ! TsisSV : Temperature [K], square interpolation between Tsf_SV (surface) and mean_temp (bottom)
+ tisSNo(i, j, n, k) = tairSL(i, j) * (1.-distup**2) + mean_temp * distup**2
+ ! firn density : densification formulas from :
+ ! Ligtenberg et al 2011 eq. (6) (www.the-cryosphere.net/5/809/2011/)
+ ! equivalent to Arthern et al. 2010 eq. (4) "Nabarro-Herring" (doi:10.1029/2009JF001306)
+ ! Integration of the steady state equation
+ ! ln_smb approximated as a function of temperature
+ ln_smb = max((mean_temp - TfSnow) * 5./60.+8., 3.)
+ ! alpha0, alpha1 : correction coefficient as a function of ln_SMB from Ligtenberg 2011, adjusted for alpha1
+ alpha0 = max(1.435 - 0.151 * ln_smb, 0.25)
+ alpha1 = max(2.0111 - 0.2051 * ln_smb, 0.25)
+ E0 = C0 * gravit * exp((E_g - E_c) / &
+ (R * mean_temp)) * ro_ice * alpha0
+ E1 = C1 * gravit * exp((E_g - E_c) / &
+ (R * mean_temp)) * ro_ice * alpha1
+ z550 = log((ro_ice / mean_dens - 1.) / &
+ (ro_ice / 550.-1.)) / E0
+ rho0 = exp(E0 * depth) / (ro_ice / &
+ mean_dens - 1 + exp(E0 * depth)) * ro_ice
+ rho1 = exp(E1 * depth) / (ro_ice &
+ / mean_dens - 1 + exp(E1 * depth)) * ro_ice
+ if(depth <= z550) then
+ rosSNo(i, j, n, k) = exp(E0 * depth) / &
+ (ro_ice / mean_dens - 1 &
+ + exp(E0 * depth)) * ro_ice
+ else
+ rosSNo(i, j, n, k) = exp(E1 * (depth - z550)) &
+ / (ro_ice / 550.-1 + &
+ exp(E1 * (depth - z550))) * ro_ice
+ endif
+ depth = depth - dzsSNo(i, j, n, k) / 2.
+ enddo
+ endif ! INI==7 (reset)
+
+ nssSNo(i, j, n) = nbr_layer
+ issSNo(i, j, n) = 0
+ snohSN(i, j, n) = 0.
+ SWaSNo(i, j, n) = 0.
+ TsrfSL(i, j, n) = tairSL(i, j)
+ TvegTV(i, j, n) = tairSL(i, j)
+ if(isolSL(i, j) == 3) then
+ isolTV(i, j) = 12
+ iwafTV(i, j) = 0
+ ivegTV(i, j, n) = 0
+ alaiTV(i, j, n) = 0.
+ glf_TV(i, j, n) = 0.
+ ! SLsrfl(i,j,1) = 1.
+ ! ifraTV(i,j,1) = 100
+ AlbSTV(i, j) = 0.55
+ do isn = 1, llx
+ TsolTV(i, j, n, isn) = max(230., tisSNo(i, j, n, 1))
+ eta_TV(i, j, n, isn) = 0.
+ enddo
+ else
+ ! albedo / 2 in SISVAT if satured soil
+ AlbSTV(i, j) = 0.25
+ do isn = 1, llx
+ eta_TV(i, j, n, isn) = max(0.01, eta_TV(i, j, n, isn))
+ if(nbr_layer > 0) then
+ TsolTV(i, j, n, isn) = max(230., tisSNo(i, j, n, 1))
+ eta_TV(i, j, n, isn) = 0.
+ endif
+ enddo
+ endif
+ enddo
+
+ if(INI == 3 .or. INI == 6) then
+ do n = 1, 1 !nsx-1
+ nssSNo(i, j, n) = ns1(i, j)
+ nisSNo(i, j, n) = ni1(i, j)
+ if(nsno < 20) then
+ print *, "inisnow: nsno<20!"; stop
+ endif
+ do k = 1, nsno
+ agsSNo(i, j, n, k) = ag1(i, j, k)
+ dzsSNo(i, j, n, k) = dz1(i, j, k)
+ nhsSNo(i, j, n, k) = nh1(i, j, k)
+ g1sSNo(i, j, n, k) = g11(i, j, k)
+ g2sSNo(i, j, n, k) = g21(i, j, k)
+ wasSNo(i, j, n, k) = wa1(i, j, k)
+ tisSNo(i, j, n, k) = max(ti1(i, j, k), 230.)
+ rosSNo(i, j, n, k) = min(920.00, max(ro1(i, j, k), 300.))
+ if(rosSNo(i, j, n, k) > 900) then
+ wasSNo(i, j, n, k) = 0.
+ tisSNo(i, j, n, k) = min(270.15, tisSNo(i, j, n, k))
+ endif
+ enddo
+ enddo
+ endif
+ endif
+ enddo
+ enddo
+
+#if(iso)
+ ! isotopic initialization of snowpack
+ call mariso_init_sno(iso_init_type, rosSNo, wasSNo, SWaSNo, rosSNo_iso, wasSNo_iso, SWaSNo_iso)
+ ! isotopic initialization of soil
+ call mariso_init_tv(iso_init_type, eta_TV, eta_TV_iso)
+ snohSN_iso = 0.
+#endif
+
+ do i = 1, mx
+ do j = 1, my
+ do k = 1, nsx
+ do n = 1, nsno
+ if(agsSNo(i, j, k, n) <= 1000 .and. dzsSNo(i, j, k, n) > 0) then
+ agsSNo(i, j, k, n) = real(jdarGE + njyrGE(mmarGE)) / 365.+iyrrGE
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! +--Initial snow height
+ ! + ===================
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nvx
+ zn0IB(i, j, k) = 0.0
+ mb0IB(i, j, k) = 0.0
+ if(nssSNo(i, j, k) > 0) then
+ do nk = nsno, 1, -1
+ if(nssSNo(i, j, k) < nk) dzsSNo(i, j, k, nk) = 0.
+ enddo
+ znsn(i, j, nsno) = dzsSNo(i, j, k, nsno)
+ snwae(i, j, nsno) = rosSNo(i, j, k, nsno) &
+ * dzsSNo(i, j, k, nsno) * 1.d3 / ro_Wat
+ do nk = nsno - 1, 1, -1
+ znsn(i, j, nk) = dzsSNo(i, j, k, nk) + znsn(i, j, nk + 1)
+ snwae(i, j, nk) = rosSNo(i, j, k, nk) * dzsSNo(i, j, k, nk) * 1.d3 &
+ / ro_Wat + snwae(i, j, nk + 1)
+ enddo
+ zn0IB(i, j, k) = max(0., znsn(i, j, 1))
+ mb0IB(i, j, k) = max(0., snwae(i, j, 1))
+ endif
+ if(nssSNo(i, j, 1) >= 10) then
+ ni = i
+ nj = j
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! +--Output
+ ! + ======
+ open(unit=111, status='replace', file='inisnow.out')
+ do nk = 1, 1
+ write(111, *) 'Coord:', ni, nj
+ write(111, 401)
+ do n = nsno, 1, -1
+ write(111, 402) n, znsn(ni, nj, n), dzsSNo(ni, nj, 1, n) * 1000, &
+ tisSNo(ni, nj, 1, n), rosSNo(ni, nj, 1, n), &
+ wasSNo(ni, nj, 1, n), snwae(ni, nj, n), &
+ agsSNo(ni, nj, 1, n), zero, zero, g1sSNo(ni, nj, 1, n), &
+ g2sSNo(ni, nj, 1, n), nhsSNo(ni, nj, 1, n)
+ enddo
+ write(111, *) 'mb0IB :', mb0IB(ni, nj, 1)
+ write(111, *) 'zn0IB :', zn0IB(ni, nj, 1)
+ write(111, *) 'nssSNo :', nssSNo(ni, nj, 1)
+ write(111, *) 'nisSNo :', nisSNo(ni, nj, 1)
+ write(111, *) 'SH :', sh(ni, nj)
+ write(111, *) 'tairSL :', tairSL(ni, nj)
+ write(111, *) 'tsrfSL :', tsrfSL(ni, nj, 1)
+ write(111, *) 't2_SL :', t2_SL(ni, nj)
+ write(111, *) 'd1_SL :', d1_SL(ni, nj)
+ write(111, *) 'SL_z0 :', SL_z0(ni, nj, 1)
+ write(111, *) 'SL_r0 :', SL_r0(ni, nj, 1)
+ write(111, *) 'SLuusl :', SLuusl(ni, nj, 1)
+ write(111, *) 'SLutsl :', SLutsl(ni, nj, 1)
+ write(111, *) 'eps0SL :', eps0SL(ni, nj)
+ enddo
+ close(111)
+
+401 format(/, ' Internal Characteristics', &
+ /, ' ========================', &
+ /, ' n | z | dz | T | rho | W |', &
+ ' z(WE) | Age | Extin | UW | Dendr.| Spher.| Hist. |', &
+ /, ' | [m] | [mm] | [K] | kg/m3 | kg/kg |', &
+ ' [mm] | [d] | | mim/s | /Sphe.| /Size | |', &
+ /, '----+-------+-------+--------+-------+-------+', &
+ '-------+-------+-------+-------+-------+-------+-------+')
+402 format((i3, ' |', f6.2, ' |', f6.1, ' |', f7.2, ' |', f6.1, ' |', &
+ f6.3, ' |', f7.0, '|', f6.1, ' |', f6.3, ' |', f6.2, ' |', &
+ 2(f6.1, ' |'), i4, ' |'))
+
+ deallocate(snwae)
+ deallocate(znsn)
+ deallocate(ag1)
+ deallocate(dz1)
+ deallocate(nh1)
+ deallocate(g11)
+ deallocate(g21)
+ deallocate(ti1)
+ deallocate(ro1)
+ deallocate(wa1)
+
+ return
+endsubroutine inisnow
+
+subroutine UPDsnow
+ ! +------------------------------------------------------------------------+
+ ! | MAR SURFACE XF MAR |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mar_ib
+
+ implicit none
+
+ ! +--Local Variables
+ ! + =================
+ integer i, j, k, n
+ real dz_old, zn_old, mb_old, ro_old, dz_tot
+ real maxlimit, minlimit
+ real, parameter :: change = 0.01 ! percentage change (0-1)
+ maxlimit = 22
+ minlimit = 20 ! Max/Min Snow Height
+! #if(GR)
+! maxlimit = 31
+! minlimit = 29
+! #endif
+
+ ! checking of zn1IB
+ ! -----------------
+ do i = 1, mx
+ do j = 1, my
+ do n = 1, nsx
+ dz_tot = 0.
+ do k = nsno, 1, -1
+ dz_tot = dzsSNo(i, j, n, k) + dz_tot
+ enddo
+ if(dz_tot > maxlimit) then
+ k = 1
+ zn_old = zn0IB(i, j, n)
+ dz_old = dzsSNo(i, j, n, k)
+ mb_old = dzsSNo(i, j, n, k) * rosSNo(i, j, n, k)
+ ro_old = rosSNo(i, j, n, k)
+ if(dz_old > 1.01) then
+ dzsSNo(i, j, n, k) = dzsSNo(i, j, n, k) - 1.
+ rosSNo(i, j, n, k) = max(rosSNo(i, j, n, k + 1), rosSNo(i, j, n, k) * &
+ (1.-change))
+ else
+ dzsSNo(i, j, n, k) = 0.1 * dzsSNo(i, j, n, k)
+ rosSNo(i, j, n, k) = rosSNo(i, j, n, k + 1)
+ endif
+
+ zn0IB(i, j, n) = zn0IB(i, j, n) + &
+ (dzsSNo(i, j, n, k) - dz_old)
+ mb0IB(i, j, n) = mb0IB(i, j, n) + rosSNo(i, j, n, k) &
+ * dzsSNo(i, j, n, k) - mb_old
+ wet0IB(i, j, n) = wet0IB(i, j, n) + rosSNo(i, j, n, k) &
+ * dzsSNo(i, j, n, k) - mb_old
+ if(n == 1) smbh0IB(i, j) = smbh0IB(i, j) + rosSNo(i, j, n, k) &
+ * dzsSNo(i, j, n, k) - mb_old
+
+ write(*, *) ' '
+ write(*, 10) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, i, j, &
+ dz_tot, dz_tot - (zn_old - zn0IB(i, j, n)), &
+ ro_old, rosSNo(i, j, n, k)
+10 format(' UPDsnow (min) at', i5, 4i3, &
+ ' for (', i3, ','i3, ') : ZN ', f5.2, '=>', f5.2, &
+ ' RO ', f8.1, '=>', f8.1)
+ write(*, *) ' '
+ endif
+ if(mskSNo(i, j, n) > 0 .and. n /= nsx .and. dz_tot > minlimit / 10. .and. dz_tot < minlimit) then
+ k = 1
+ zn_old = zn0IB(i, j, n)
+ dz_old = dzsSNo(i, j, n, k)
+ mb_old = dzsSNo(i, j, n, k) * rosSNo(i, j, n, k)
+ ro_old = rosSNo(i, j, n, k)
+ ! warning : it might not be ok for Antarctica
+ ! todo : check if ok for Antarctica
+ ! tisSNo(i,j,n,k) = min(tisSNo(i,j,n,k)*0.999,272.15)
+ tisSNo(i, j, n, k) = min(tisSNo(i, j, n, k), 272.15)
+ if(tisSNo(i, j, n, k) <= 273.15 - 15) then
+ tisSNo(i, j, n, k) = (tisSNo(i, j, n, k) * dzsSNo(i, j, n, k) + 273.15 - 15 * 1) / (dzsSNo(i, j, n, k) + 1)
+ endif
+
+ dzsSNo(i, j, n, k) = dzsSNo(i, j, n, k) + 1.
+
+ if(dz_tot > minlimit - 1.) then
+ rosSNo(i, j, n, k) = rosSNo(i, j, n, k) * (1.+change)
+ wasSNo(i, j, n, k) = wasSNo(i, j, n, k) * (1.-change)
+ else
+ wasSNo(i, j, n, k) = wasSNo(i, j, n, k) * dz_old &
+ / dzsSNo(i, j, n, k)
+ endif
+
+ if(rosSNo(i, j, n, k) > 875) then
+ rosSNo(i, j, n, k) = ro_ice
+ wasSNo(i, j, n, k) = 0.
+ endif
+
+ zn0IB(i, j, n) = zn0IB(i, j, n) + &
+ (dzsSNo(i, j, n, k) - dz_old)
+ mb0IB(i, j, n) = mb0IB(i, j, n) + rosSNo(i, j, n, k) &
+ * dzsSNo(i, j, n, k) - mb_old
+ wet0IB(i, j, n) = wet0IB(i, j, n) + rosSNo(i, j, n, k) &
+ * dzsSNo(i, j, n, k) - mb_old
+ if(n == 1) smbh0IB(i, j) = smbh0IB(i, j) + rosSNo(i, j, n, k) &
+ * dzsSNo(i, j, n, k) - mb_old
+
+ write(*, *) ' '
+ write(*, 11) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, i, j, &
+ dz_tot, dz_tot + (zn0IB(i, j, n) - zn_old), &
+ ro_old, rosSNo(i, j, n, k)
+11 format(' UPDsnow (add) at', i5, 4i3, &
+ ' for (', i3, ','i3, ') : ZN ', f5.2, '=>', f5.2, &
+ ' RO ', f8.1, '=>', f8.1)
+ write(*, *) ' '
+ endif
+ enddo
+ enddo
+ enddo
+endsubroutine UPDsnow
+
+subroutine FILsnow
+ ! +------------------------------------------------------------------------+
+ ! | MAR SURFACE XF MAR |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use marctr
+ use mar_sv
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_lb
+ use mar_sl
+ use mar_bs
+ use mar_io
+ use mar_tv
+ use marssn
+ use mardsv
+ use mar_ib
+
+ implicit none
+
+ ! +--Local Variables
+ ! + =================
+
+ integer i, j, k, n, l, filtering
+ real ro_new, ww, g1_new, g2_new, ti_new, al_new
+ real nbr1, nbr2
+
+ do i = 2, mx - 1; do j = 2, my - 1; do n = 1, nsx - 1 !*CL*
+ if(mskSNo(i, j, n) >= 50) then !*CL*
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ nbr1 = 0; nbr2 = 0
+ g1_new = 0; g2_new = 0; ro_new = 0; ti_new = 0; al_new = 0
+
+ do k = -1, 1; do l = -1, 1
+ if(mskSNo(i + k, j + l, n) >= 50 .and. &
+ rosSNo(i + k, j + l, n, max(1, nssSNo(i + k, j + l, n))) < roCdSV) then
+ ww = 1
+ if(k == 0 .or. l == 0) ww = 2
+ if(k == 0 .and. l == 0) ww = 4
+
+ ww = ww * dzsSNo(i + k, j + l, n, nssSNo(i + k, j + l, n))
+
+ if(g1sSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) >= 0) then
+ g1_new = g1_new + g1sSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+ g2_new = g2_new + g2sSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+ endif
+
+ ro_new = ro_new + rosSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+ ti_new = ti_new + tisSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+ al_new = al_new + albxSL(i + k, j + l, n) * ww
+
+ nbr1 = nbr1 + ww
+ nbr2 = nbr2 + 1
+
+ endif
+ enddo;
+ enddo
+
+ g1_new = g1_new / nbr1
+ g2_new = g2_new / nbr1
+ ro_new = ro_new / nbr1
+ ti_new = ti_new / nbr1
+ al_new = al_new / nbr1
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ filtering = 0
+
+ if(nbr2 == 9 .and. &
+ g2sSNo(i, j, n, nssSNo(i, j, n)) > 1.1 * g2_new .and. &
+ rosSNo(i, j, n, nssSNo(i, j, n)) < roCdSV .and. &
+ albxSL(i, j, n) < al_new - 0.05 .and. &
+ g2_new < 50. .and. &
+ albxSL(i, j, n) < 0.70 .and. &
+ albxSL(i, j, n) > 0.50 .and. &
+ g2sSNo(i, j, n, nssSNo(i, j, n)) < 75.) filtering = 1
+
+ ! if(nbr2==9.and.albxSL(i,j,n)<al_new-0.1 .and.
+ ! . g2sSNo(i,j,n,nssSNo(i,j,n))<80 .and.
+ ! . g1sSNo(i,j,n,nssSNo(i,j,n))<80 ) filtering=2
+
+ if(filtering > 0) then
+
+ write(*, *) ' '
+ write(*, 12) iyrrGE, mmarGE, jdarGE, jhurGE, minuGE, i, j, filtering, &
+ rosSNo(i, j, n, nssSNo(i, j, n)), ro_new, &
+ g1sSNo(i, j, n, nssSNo(i, j, n)), g1_new, &
+ g2sSNo(i, j, n, nssSNo(i, j, n)), g2_new, &
+ albxSL(i, j, n), al_new
+12 format('Filtering', &
+ i5, 4i3, ' for (', i3, ','i3, ')', i2, f6.1, '=>', f6.1, &
+ f6.1, '=>', f6.1, ',', f7.2, '=>', f7.2, f5.2, '=>', f5.2)
+ write(*, *)
+
+ g1sSNo(i, j, n, nssSNo(i, j, n)) = min(g1_new, &
+ g1sSNo(i, j, n, nssSNo(i, j, n)))
+ g2sSNo(i, j, n, nssSNo(i, j, n)) = min(g2_new, &
+ g2sSNo(i, j, n, nssSNo(i, j, n)))
+ tisSNo(i, j, n, nssSNo(i, j, n)) = min(ti_new, &
+ tisSNo(i, j, n, nssSNo(i, j, n)))
+ ro_new = min(ro_new, &
+ rosSNo(i, j, n, nssSNo(i, j, n)))
+ dzsSNo(i, j, n, nssSNo(i, j, n)) = dzsSNo(i, j, n, nssSNo(i, j, n)) &
+ * rosSNo(i, j, n, nssSNo(i, j, n)) &
+ / ro_new
+ rosSNo(i, j, n, nssSNo(i, j, n)) = ro_new
+ endif
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ if(mmarGE <= 3 .or. mmarGE >= 11) then
+ tisSNo(i, j, n, 1) = min(273.14, tisSNo(i, j, n, 1))
+ endif
+
+ endif;
+ enddo;
+ enddo;
+ enddo
+
+endsubroutine FILsnow
+
+subroutine OUTone(TypeGL, ONEint)
+ ! +------------------------------------------------------------------------+
+ ! | MAR OUTPUT XF MAR |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use marctr
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_ge
+ use mar_sl
+ use mar_hy
+ use mar_ra
+ use mar_sv
+ use marssn
+ use mar_ib
+ use mar_io
+ use mar_wk
+ use mar_ca
+ use mar_tv
+ use mar_te
+ use mar_tu
+
+ implicit none
+
+ INCLUDE 'NetCDF.inc'
+
+ ! +--Local Variables
+ ! + ================
+ ! +
+ character * (40) fnamNC_one
+ common / out_nc_one_loc / fnamNC_one
+ ! +... fnamNC_one: To retain file name.
+
+ integer NdimNC_one
+ PARAMETER(NdimNC_one=8)
+ ! +...Number of defined spatial dimensions (exact)
+
+ integer MXdim
+ PARAMETER(MXdim=9000)
+ ! +...Maximum Number of all dims: recorded Time Steps
+ ! + and also maximum of spatial grid points for each direction.
+
+ integer MX_var
+ PARAMETER(MX_var=120)
+ ! +...Maximum Number of Variables
+
+ integer NattNC_one
+ PARAMETER(NattNC_one=2)
+ ! +...Number of real attributes given to all variables
+
+ ! ------------------------------------------------------------
+ integer, intent(in) :: ONEint ! interval (min)
+ integer, parameter :: ONElev = mz ! nbr levels (<=mz)
+ integer, parameter :: ONEnbr = 200 ! max nbr of stations
+ !CA integer , parameter :: ONEint = 5 ! interval (min)
+ ! ------------------------------------------------------------
+
+ integer i, j, k
+ integer ONEsta ! real nbr of stations
+ integer io
+ integer i_one(ONEnbr), j_one(ONEnbr)
+ character * 6 name_tmp
+ character * 16 attr_tmp
+ real x0, y0
+ real x_tmp, y_tmp, lon_tmp, lat_tmp, sh_tmp
+ integer i_tmp, j_tmp
+ real lon_one(ONEnbr), lat_one(ONEnbr), sh_one(ONEnbr)
+ real x_one(ONEnbr), y_one(ONEnbr)
+ real one1(ONEnbr), one2(ONEnbr)
+ real one3(ONEnbr), one4(ONEnbr)
+ real one5(ONEnbr), one6(ONEnbr)
+ real one7(ONEnbr, ONElev), one8(ONEnbr, ONElev)
+ real one9(ONEnbr, ONElev), one10(ONEnbr, ONElev)
+ real one11(ONEnbr, nsno), one12(ONEnbr, nsno)
+ real one13(ONEnbr, nsno)
+ real one14(ONEnbr, llx), one15(ONEnbr, llx)
+ real one16(8)
+ real one0snf(ONEnbr), one0rnf(ONEnbr)
+ real one0rof(ONEnbr), one0evp(ONEnbr)
+ real uu(ONElev), vv(ONElev)
+ real WS(ONEnbr, ONElev), WD(ONEnbr, ONElev)
+ real RH(ONEnbr, ONElev)
+
+ real starti, starta
+ real yearNC_one(MXdim)
+ real dateNC_one(MXdim)
+ real timeNC_one(MXdim)
+ real VALdim(MXdim, 0:NdimNC_one)
+
+ integer njmo, ipr_nc_one
+ integer jourNC_one(MXdim)
+ integer moisNC_one(MXdim)
+ integer NvatNC_one(NattNC_one)
+ integer nDFdim(0:NdimNC_one)
+
+ character * (13) NAMdim(0:NdimNC_one)
+ character * (31) UNIdim(0:NdimNC_one)
+ character * (13) SdimNC_one(4, MX_var)
+ character * (31) unitNC_one(MX_var)
+ character * (13) nameNC_one(MX_var)
+ character * (50) lnamNC_one(MX_var)
+ character * (100) tit_nc_one
+ character * (13) NAMrat(NattNC_one)
+ character * 120 tmpINP
+ character * 20 n_one(ONEnbr)
+ character * 2 station
+ character * 10 TypeGL
+
+ integer n1000, n100a, n100, n10_a, n10, n1, m10, jd10, jd1
+ integer it, mois, mill, itotNC_one
+ integer NtotNC_one, ID__nc_one
+ integer nbr_day, nbr_output, dt2
+
+ integer ii, jj, kk, ll, s, n, mm, nn, one, imex, jmex, t
+ real qsat0D, q, qst, r, rst, epsilon
+
+ integer ii_sh, jj_sh
+ real dsh, dshmin
+
+ logical file_exists
+
+ common / OUTone_i / ONEsta, nDFdim, ipr_nc_one, i_one, j_one
+ common / OUTone_r / yearNC_one, dateNC_one, timeNC_one
+ common / OUTone_c / n_one
+ common / OUTone_0 / one0snf, one0rnf, one0rof, one0evp
+
+ real, parameter :: a = &
+ 6371.229 * 1000.0 ! radius of the Earth
+ real, parameter :: conv = &
+ 15.0 * 3.141592 / 180.0 ! Conversion
+ ! ! hour ==> rad
+
+ ! 1. Station Location Initialization
+ ! ==================================
+
+ if(iterun == 0) then
+
+ print *, ' '
+ print *, 'OUTone initialisation for '//trim(TypeGL)
+ print *, '================================'
+ print *, ' '
+
+ if(TypeGL(1:2) == "AN") then
+ ONEsta = 0
+ call stereosouth_inverse(GElon0, GElat0, GEddxx, x0, y0)
+ inquire(file='ONEstation.dat', exist=file_exists)
+ if(file_exists) then
+ open(unit=10, status='old', file='ONEstation.dat')
+ !CA write(6,*) "ONEtest 4"
+ io = 0
+ do while(io == 0)
+ read(10, '(A)', iostat=io) tmpINP
+ if(io == 0) then
+ if(tmpINP(1:4) == ' ') then
+ read(tmpINP, &
+ '(4x,A6,4x,A21,1x,f6.2,1x,f11.7,1x,f10.1)') &
+ name_tmp, attr_tmp, lat_tmp, lon_tmp, sh_tmp
+ call stereosouth_inverse(lon_tmp, lat_tmp, &
+ GEddxx, x_tmp, y_tmp)
+ i_tmp = nint((x_tmp - x0) * 1000./dx) + imez
+ j_tmp = nint((y_tmp - y0) * 1000./dy) + jmez
+ ! find the closest surface elevation among
+ ! the four surrounding grid cells
+ dshmin = sh(i_tmp, j_tmp)
+ ii_sh = i_tmp
+ jj_sh = j_tmp
+ do jj = j_tmp - 1, j_tmp + 1
+ dsh = abs(sh_tmp - sh(i_tmp, jj))
+ if(dsh < dshmin) then
+ ii_sh = i_tmp
+ jj_sh = jj
+ dshmin = dsh
+ endif
+ enddo
+ do ii = i_tmp - 1, i_tmp + 1
+ dsh = abs(sh_tmp - sh(ii, j_tmp))
+ if(dsh < dshmin) then
+ ii_sh = ii
+ jj_sh = j_tmp
+ dshmin = dsh
+ endif
+ enddo
+ i_tmp = ii_sh
+ j_tmp = jj_sh
+ ! save grid point
+ if(i_tmp >= 1 .and. i_tmp <= mx &
+ .and. j_tmp >= 1 .and. j_tmp <= my) then
+ ONEsta = ONEsta + 1
+ s = ONEsta
+ n_one(s) = name_tmp
+ i_one(s) = i_tmp
+ j_one(s) = j_tmp
+ lon_one(s) = lon_tmp
+ lat_one(s) = lat_tmp
+ sh_one(s) = sh_tmp
+ x_one(s) = x_tmp
+ y_one(s) = y_tmp
+ endif
+ endif
+ endif
+ enddo
+ close(unit=10)
+ else
+ write(6, *) "=================================="
+ write(6, *) "ERROR: ONEstation.dat file missing"
+ write(6, *) "STOP in OUTone"
+ write(6, *) "=================================="
+ stop
+ endif
+ if(ONEsta > ONEnbr) then
+ print *, "ERROR: number of stations in ONEstation.dat"
+ print *, "is greater than ONEnbr (", ONEnbr, ")"
+ print *, ">> increase ONEnbr in subrout. OUTone"
+ stop
+ endif
+ call stereosouth_inverse(GElon0, GElat0, GEddxx, x0, y0)
+ else
+ ONEsta = ONEnbr
+ endif
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ if(trim(TypeGL) == 'GR25km') then
+ s = 1
+ i_one(s) = 20; j_one(s) = 63; n_one(s) = "Aasiat"; s = s + 1 !
+ i_one(s) = 28; j_one(s) = 126; n_one(s) = "Alert"; s = s + 1 !
+ i_one(s) = 28; j_one(s) = 55; n_one(s) = "Aurora"; s = s + 1 !
+ i_one(s) = 52; j_one(s) = 57; n_one(s) = "Aputiek"; s = s + 1 !
+ i_one(s) = 43; j_one(s) = 75; n_one(s) = "Barber"; s = s + 1 !
+ i_one(s) = 31; j_one(s) = 67; n_one(s) = "Crawford 1"; s = s + 1 !
+ i_one(s) = 31; j_one(s) = 66; n_one(s) = "Crawford 2"; s = s + 1 !
+ i_one(s) = 65; j_one(s) = 91; n_one(s) = "Daneborg"; s = s + 1 !
+ i_one(s) = 62; j_one(s) = 101; n_one(s) = "Dove Bugt"; s = s + 1 ! (63,101)
+ i_one(s) = 12; j_one(s) = 103; n_one(s) = "Dundas"; s = s + 1 !
+ i_one(s) = 30; j_one(s) = 52; n_one(s) = "Dye-2"; s = s + 1 !
+ i_one(s) = 34; j_one(s) = 46; n_one(s) = "Dye-3"; s = s + 1 !
+ i_one(s) = 27; j_one(s) = 67; n_one(s) = "ETH-camp"; s = s + 1 !
+ i_one(s) = 22; j_one(s) = 56; n_one(s) = "GIMEX-Mast 1"; s = s + 1 !
+ i_one(s) = 23; j_one(s) = 56; n_one(s) = "GIMEX-Mast 2"; s = s + 1 !
+ i_one(s) = 24; j_one(s) = 56; n_one(s) = "GIMEX-Mast 5"; s = s + 1 !
+ i_one(s) = 25; j_one(s) = 56; n_one(s) = "GIMEX-Mast 6"; s = s + 1 !
+ i_one(s) = 26; j_one(s) = 56; n_one(s) = "GIMEX-Mast 6-9"; s = s + 1 !
+ i_one(s) = 27; j_one(s) = 56; n_one(s) = "GIMEX-Mast 9"; s = s + 1 !
+ i_one(s) = 21; j_one(s) = 104; n_one(s) = "Gits"; s = s + 1 ! (21,104)
+ i_one(s) = 43; j_one(s) = 79; n_one(s) = "Gisp2 (Summit)"; s = s + 1 !
+ i_one(s) = 44; j_one(s) = 79; n_one(s) = "Grip"; s = s + 1 !
+ i_one(s) = 28; j_one(s) = 121; n_one(s) = "Hall Land"; s = s + 1 !
+ i_one(s) = 27; j_one(s) = 108; n_one(s) = "Humboldt"; s = s + 1 !
+ i_one(s) = 36; j_one(s) = 31; n_one(s) = "Ikermiuarsuk"; s = s + 1 !
+ i_one(s) = 24; j_one(s) = 66; n_one(s) = "Ilulissat"; s = s + 1 !
+ i_one(s) = 26; j_one(s) = 67; n_one(s) = "Jar1"; s = s + 1 !
+ i_one(s) = 25; j_one(s) = 67; n_one(s) = "Jar2"; s = s + 1 !
+ i_one(s) = 25; j_one(s) = 66; n_one(s) = "Jar3"; s = s + 1 !
+ i_one(s) = 48; j_one(s) = 79; n_one(s) = "Julie"; s = s + 1 !
+ i_one(s) = 23; j_one(s) = 56; n_one(s) = "Kangerdlugssuaq"; s = s + 1 !
+ i_one(s) = 22; j_one(s) = 30; n_one(s) = "Kangilinnguit"; s = s + 1 !
+ i_one(s) = 44; j_one(s) = 128; n_one(s) = "Kap M. Jesup "; s = s + 1 !
+ i_one(s) = 51; j_one(s) = 66; n_one(s) = "Kar"; s = s + 1 !
+ i_one(s) = 43; j_one(s) = 78; n_one(s) = "Kenton"; s = s + 1 !
+ i_one(s) = 40; j_one(s) = 78; n_one(s) = "Klinck (Mast10)"; s = s + 1 !
+ i_one(s) = 42; j_one(s) = 49; n_one(s) = "Kulu"; s = s + 1 !
+ i_one(s) = 52; j_one(s) = 91; n_one(s) = "Nasa-E"; s = s + 1 !
+ i_one(s) = 36; j_one(s) = 53; n_one(s) = "Nasa-SE"; s = s + 1 !
+ i_one(s) = 29; j_one(s) = 86; n_one(s) = "Nasa-U"; s = s + 1 !
+ i_one(s) = 44; j_one(s) = 84; n_one(s) = "Matt"; s = s + 1 !
+ i_one(s) = 29; j_one(s) = 29; n_one(s) = "Narssarssuaq"; s = s + 1 !
+ i_one(s) = 30; j_one(s) = 102; n_one(s) = "NEEM1"; s = s + 1 !
+ i_one(s) = 31; j_one(s) = 102; n_one(s) = "NEEM2"; s = s + 1 !
+ i_one(s) = 38; j_one(s) = 90; n_one(s) = "Ngrip"; s = s + 1 !
+ i_one(s) = 56; j_one(s) = 122; n_one(s) = "Nord"; s = s + 1 !
+ i_one(s) = 19; j_one(s) = 44; n_one(s) = "Nuuk (Godthab)"; s = s + 1 !
+ i_one(s) = 21; j_one(s) = 34; n_one(s) = "Paamiut"; s = s + 1 !
+ i_one(s) = 34; j_one(s) = 24; n_one(s) = "Prins Ch"; s = s + 1 !
+ i_one(s) = 29; j_one(s) = 27; n_one(s) = "Qaqortoq"; s = s + 1 !
+ i_one(s) = 33; j_one(s) = 50; n_one(s) = "Saddle"; s = s + 1 !
+ i_one(s) = 18; j_one(s) = 48; n_one(s) = "Sioralik"; s = s + 1 ! Maniitsoq
+ i_one(s) = 18; j_one(s) = 55; n_one(s) = "Sisimiut"; s = s + 1 !
+ i_one(s) = 31; j_one(s) = 38; n_one(s) = "South Dome"; s = s + 1 !
+ i_one(s) = 44; j_one(s) = 78; n_one(s) = "Summit (Cathy)"; s = s + 1 !
+ i_one(s) = 46; j_one(s) = 49; n_one(s) = "Tasiilaq"; s = s + 1 !
+ i_one(s) = 13; j_one(s) = 104; n_one(s) = "Thules"; s = s + 1 !
+ i_one(s) = 47; j_one(s) = 104; n_one(s) = "Tunu-N"; s = s + 1 !
+ i_one(s) = 21; j_one(s) = 82; n_one(s) = "Upernavik"; s = s + 1 !
+ i_one(s) = 67; j_one(s) = 71; n_one(s) = "Uunartoq"; s = s + 1 !
+ one = s - 1
+ ONEsta = one
+
+ endif
+
+ if(trim(TypeGL) == 'SVa') then
+ n_one(1) = 'Svalbard Lufthavn'
+ i_one(1) = 36; j_one(1) = 44
+
+ n_one(2) = 'Hopen'
+ i_one(2) = 60; j_one(2) = 26
+
+ n_one(3) = 'NY-Alesund'
+ i_one(3) = 27; j_one(3) = 52
+
+ n_one(4) = 'Sveagruva'
+ i_one(4) = 36; j_one(4) = 40
+
+ n_one(5) = 'Barentsburg'
+ i_one(5) = 32; j_one(5) = 42
+
+ n_one(6) = 'Adventalen'
+ i_one(6) = 36; j_one(6) = 44
+
+ n_one(7) = 'Breinosa (Kho Aurora Station)'
+ i_one(7) = 36; j_one(7) = 40
+
+ n_one(8) = 'Janssonhaugen'
+ i_one(8) = 36; j_one(8) = 40
+
+ n_one(9) = 'Gruvefjellet'
+ i_one(9) = 34; j_one(9) = 40
+
+ n_one(10) = 'Kapp Lee'
+ i_one(10) = 48; j_one(10) = 42
+
+ n_one(11) = 'Rijpfjorden'
+ i_one(11) = 45; j_one(11) = 39
+
+ n_one(12) = 'Kvitoya'
+ i_one(12) = 67; j_one(12) = 68
+
+ n_one(13) = 'Kongsoya'
+ i_one(13) = 65; j_one(13) = 53
+
+ n_one(14) = 'Verlegenhuken'
+ i_one(14) = 38; j_one(14) = 64
+
+ n_one(15) = 'Edgeoya-Kapp Heuglin'
+ i_one(15) = 53; j_one(15) = 44
+
+ n_one(16) = 'Svarttangen'
+ i_one(16) = 49; j_one(16) = 36
+
+ n_one(17) = 'Isfjord Radio'
+ i_one(17) = 32; j_one(17) = 42
+
+ n_one(18) = 'Hornsund'
+ i_one(18) = 35; j_one(18) = 30
+
+ n_one(19) = 'Svalbard LH - Plataberget'
+ i_one(19) = 36; j_one(19) = 43
+
+ one = 19
+ ONEsta = one
+
+ endif
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ print *, ' '
+ print *, 'Weather Stations MAR coordinates'
+ print *, ' for Simulation '//trim(TypeGL); print *, ' '
+ print *, ' N ii jj Name'
+ print *, '------------------------------'
+
+ do ll = 1, ONEsta
+ i_one(ll) = max(1, min(i_one(ll), mx))
+ j_one(ll) = max(1, min(j_one(ll), my))
+ write(*, '(3i4,x,a20)') ll, i_one(ll), j_one(ll), n_one(ll)
+ enddo
+
+ print *, '------------------------------'
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! 1.2 variables initialization
+ ! ----------------------------
+ one0snf = 0.
+ one0rnf = 0.
+ one0rof = 0.
+ one0evp = 0.
+
+ ! 2. NetCDF File Initialization
+ ! =============================
+
+ n1000 = 1 + iyrrGE / 1000
+ n100a = mod(iyrrGE, 1000)
+ n100 = 1 + n100a / 100
+ n10_a = mod(n100a, 100)
+ n10 = 1 + n10_a / 10
+ n1 = 1 + mod(n10_a, 10)
+ m10 = 1 + mmarGE / 10
+ m1 = 1 + mod(mmarGE, 10)
+ jd10 = 1 + jdarGE / 10
+ jd1 = 1 + mod(jdarGE, 10)
+
+ ! + 2.1 Output File Label
+ ! + ---------------------
+
+ fnamNC_one = 'ONE.' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1) &
+ //'.'//explIO &
+ //'.nc '
+
+ ! + 2.2 Output Title
+ ! + ----------------
+
+ tit_nc_one = 'ONE' &
+ //' - Exp: '//explIO &
+ //' - ' &
+ //labnum(n1000)//labnum(n100) &
+ //labnum(n10)//labnum(n1) &
+ //labnum(m10)//labnum(m1) &
+ //labnum(jd10)//labnum(jd1)
+
+ ! + 2.3 Time Variable (hour)
+ ! + ------------------------
+
+ ! ++++++++++++++++++++++++++++
+ ipr_nc_one = 0
+ nbr_output = int(real(max(1, int(nterun * dt / 86400))) &
+ * 24.0 * 60.0 / real(ONEint))
+ nDFdim(0) = nbr_output
+ nDFdim(0) = 0 ! Unlimited
+ ! ++++++++++++++++++++++++++++
+
+ NAMdim(0) = 'time'
+ UNIdim(0) = 'HOURS since 1901-01-15 00:00:00'
+
+ if(nbr_output > MXdim) &
+ STOP '*** out_nc_one - ERROR : MXdim to low ***'
+
+ ! starti : Starting Time
+ starti = jhurGE + minuGE / 60.0 + jsecGE / 3600.0 - dt / 3600.0
+
+ ! starta : Nb Days before iyrrGE
+ ! (iyrrGE -1901) / 4 : Nb Leap Years
+ ! njyrGE(mmarGE) : Nb Days before mmarGE
+ ! njybGE(mmarGE) : including Leap Day
+ starta = (351 + (iyrrGE - 1902) * 365 &
+ + (iyrrGE - 1901) / 4 &
+ + njyrGE(mmarGE) &
+ + njybGE(mmarGE) * max(0, 1 - mod(iyrrGE, 4)) &
+ + jdarGE - 1) * 24 &
+ + jhurGE + (minuGE * 60 + jsecGE - dt) / 3600.
+
+ do it = 1, nbr_output
+ timeNC_one(it) = starti + (it - 1) * ONEint / 60.
+ VALdim(it, 0) = starta + (it - 1) * ONEint / 60.
+ dateNC_one(it) = timeNC_one(it)
+ jourNC_one(it) = jdarGE + timeNC_one(it) / 24.
+ enddo
+ mois = mmarGE
+ mill = iyrrGE
+ do it = 1, nbr_output
+ if(mois == 2 .and. &
+ mod(mill, 4) == 0) then
+ njmo = njmoGE(mois) + 1
+ else
+ njmo = njmoGE(mois)
+ endif
+
+ if(jourNC_one(it) > njmo) then
+ do t = it, nbr_output
+ jourNC_one(t) = jourNC_one(t) - njmo
+ enddo
+ mois = mois + 1
+ if(mois > 12) then
+ mois = 1
+ mill = mill + 1
+ endif
+ endif
+ moisNC_one(it) = mois
+ yearNC_one(it) = mill
+
+ if(dateNC_one(it) > 24.-epsi) then
+ do t = it, nbr_output
+ dateNC_one(t) = mod(dateNC_one(t), 24.)
+ enddo
+ endif
+ enddo
+
+ do it = 1, nbr_output
+ dateNC_one(it) = dateNC_one(it) &
+ + 1.d+2 * jourNC_one(it) &
+ + 1.d+4 * moisNC_one(it) &
+ + 1.d+6 * yearNC_one(it)
+ enddo
+
+ ! + 2.4 Define horizontal spatial dimensions
+ ! + ----------------------------------------
+
+ do i = 1, mx
+ VALdim(i, 1) = xxkm(i)
+ enddo
+ nDFdim(1) = mx; NAMdim(1) = 'x'; UNIdim(1) = 'km'
+
+ do j = 1, my
+ VALdim(j, 2) = yykm(j)
+ enddo
+ nDFdim(2) = my; NAMdim(2) = 'y'; UNIdim(2) = 'km'
+
+ do k = 1, ONElev
+ VALdim(k, 3) = sigma(mz - k + 1)
+ enddo
+ nDFdim(3) = ONElev; NAMdim(3) = 'level'; UNIdim(3) = '[sigma]'
+
+ do k = 1, ONEsta
+ VALdim(k, 4) = k
+ enddo
+ nDFdim(4) = ONEsta; NAMdim(4) = 'station'; UNIdim(4) = '[-]'
+
+ do k = 1, nsx
+ VALdim(k, 5) = k
+ enddo
+ nDFdim(5) = nsx; NAMdim(5) = 'sector'; UNIdim(5) = '[index]'
+
+ do k = 1, nsno
+ VALdim(k, 6) = k
+ enddo
+ nDFdim(6) = nsno; NAMdim(6) = 'snolay'; UNIdim(6) = '[index]'
+
+ do k = 1, nsol + 1
+ VALdim(k, 7) = k
+ enddo
+ nDFdim(7) = nsol + 1; NAMdim(7) = 'sollay'; UNIdim(7) = '[-]'
+
+ do k = 1, 8
+ VALdim(k, 8) = k
+ enddo
+ nDFdim(8) = 8; NAMdim(8) = 'info'; UNIdim(8) = '[-]'
+
+ ! + 2.5 Variable's Choice (Table ONEvou.dat)
+ ! + ----------------------------------------
+
+ do ll = 1, ONEsta
+
+ if(LL <= 9) then
+ write(station, '(i1)') ll
+ else
+ write(station, '(i2)') ll
+ endif
+
+ nameNC_one(ll) = "S"//station
+ SdimNC_one(1, ll) = "info"
+ SdimNC_one(2, ll) = "-"
+ SdimNC_one(3, ll) = "-"
+ SdimNC_one(4, ll) = "-"
+ unitNC_one(ll) = "-"
+ lnamNC_one(ll) = n_one(ll)
+
+ enddo
+
+ OPEN(unit=10, status='old', file='ONEvou.dat')
+
+ itotNC_one = ONEsta
+980 continue
+ READ(10, '(A120)', end=990) tmpINP
+ if(tmpINP(1:4) == ' ') then
+ itotNC_one = itotNC_one + 1
+ READ(tmpINP, '(4x,5A9,A12,A50)') &
+ nameNC_one(itotNC_one), &
+ SdimNC_one(1, itotNC_one), &
+ SdimNC_one(2, itotNC_one), &
+ SdimNC_one(3, itotNC_one), &
+ SdimNC_one(4, itotNC_one), &
+ unitNC_one(itotNC_one), &
+ lnamNC_one(itotNC_one)
+ endif
+ GOTO 980
+990 continue
+
+ CLOSE(unit=10)
+
+ NtotNC_one = itotNC_one
+ ! +... NtotNC_one : Total number of variables writen in NetCDF file.
+
+ ! + 2.6 List of NetCDF attributes given to all variables
+ ! + ----------------------------------------------------
+
+ NAMrat(1) = 'actual_range'
+ NvatNC_one(1) = 2
+
+ NAMrat(NattNC_one) = '[var]_range'
+ NvatNC_one(NattNC_one) = 2
+
+ ! + 2.7 Automatic Generation of the NetCDF File Structure
+ ! + -----------------------------------------------------
+
+ ! + **************
+ call UNscreate(fnamNC_one, tit_nc_one, &
+ NdimNC_one, nDFdim, MXdim, NAMdim, UNIdim, &
+ VALdim, &
+ MX_var, NtotNC_one, nameNC_one, SdimNC_one, &
+ unitNC_one, &
+ lnamNC_one, &
+ NattNC_one, NAMrat, NvatNC_one, &
+ ID__nc_one)
+ ! + **************
+
+ ! + 2.8 Write Time - Constants
+ ! + --------------------------
+
+ imex = int(mx / 2)
+ jmex = int(my / 2)
+
+ Wkxy1 = GElonh * 15. ! Hour->degrees
+ WKxy2 = GElatr / degrad ! rad ->degree
+ WKxy3 = real(isolSL) ! REAL type
+ WKxy4(:, :) = real(mskSNo(:, :, 1)) ! REAL type
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'LON', 1, mx, my, 1, Wkxy1)
+ call UNwrite(ID__nc_one, 'LAT', 1, mx, my, 1, Wkxy2)
+ call UNwrite(ID__nc_one, 'SH', 1, mx, my, 1, sh)
+ call UNwrite(ID__nc_one, 'SRF', 1, mx, my, 1, Wkxy3)
+ call UNwrite(ID__nc_one, 'SLO', 1, mx, my, 1, slopTV)
+ call UNwrite(ID__nc_one, 'MSK', 1, mx, my, 1, WKxy4)
+ ! + ************
+
+ open(unit=1000, status='replace', file='OUTone.jnl')
+
+ do ll = 1, ONEsta
+
+ one16(1) = i_one(ll)
+ one16(2) = j_one(ll)
+ one16(3) = Wkxy1(i_one(ll), j_one(ll))
+ one16(4) = Wkxy2(i_one(ll), j_one(ll))
+ one16(5) = sh(i_one(ll), j_one(ll))
+ one16(6) = Wkxy4(i_one(ll), j_one(ll))
+ one16(7) = dx * (i_one(ll) - imez) * 1.e-3
+ one16(8) = dx * (j_one(ll) - jmez) * 1.e-3
+
+ if(LL <= 9) then
+ write(station, '(i1)') ll
+ else
+ write(station, '(i2)') ll
+ endif
+
+ call UNwrite(ID__nc_one, "S"//station, 1, 8, 1, 1, one16)
+
+ write(1000, 1001) one16(7), one16(8), n_one(ll)
+1001 format('LABEL ', 2(f8.2, ','), '-1,0,.10 @TR+', a20)
+
+ enddo
+
+ ! + 2.9 Re-Open file if already created.
+ ! + -----------------------------------
+
+ write(*, *) ' '
+ write(*, *) 'End of OUTone initialisation'
+ write(*, *) '============================'
+ write(*, *) ' '
+
+ GOTO 1000
+
+ else
+
+ ! + ************
+ call UNwopen(fnamNC_one, ID__nc_one)
+ ! + ************
+
+ endif
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ ! 3. Write Time-dependent variables
+ ! =================================
+ ! ipr_nc_one = ipr_nc_one + 1 : not use with Fortran 77
+ ipr_nc_one = ipr_nc_one + 1
+
+ ! write(*,*) ' '
+ ! write(*,10) ipr_nc_one,iyrrGE,mmarGE,jdarGE,jhurGE,minuGE
+ ! 10 format(' OUTone call (',i4,'):',i5,4i3)
+ ! write(*,*)
+
+ if(nDFdim(0) == 0) then
+ dt2 = dt
+ if(iterun >= nterun - 1) dt2 = 0
+ ! starta : Nb Days before iyrrGE
+ ! iyrrGE - 1901) / 4 : Nb Leap Years
+ ! njyrGE(mmarGE) : Nb Days before mmarGE
+ ! njybGE(mmarGE) : including Leap Day
+ starta = (351 + (iyrrGE - 1902) * 365 &
+ + (iyrrGE - 1901) / 4 &
+ + njyrGE(mmarGE) &
+ + njybGE(mmarGE) &
+ * max(0, 1 - mod(iyrrGE, 4)) &
+ + jdarGE - 1) * 24 &
+ + jhurGE + (minuGE * 60 + jsecGE - dt2) / 3600.!
+ ! + ************
+ call UNwrite(ID__nc_one, 'time', ipr_nc_one, 1, 1, 1, starta)
+ ! + ************
+ endif
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'DATE', ipr_nc_one, 1, 1, 1, &
+ dateNC_one(ipr_nc_one))
+ call UNwrite(ID__nc_one, 'year', ipr_nc_one, 1, 1, 1, &
+ yearNC_one(ipr_nc_one))
+ ! + ************
+
+ ! + ************
+ starta = iyrrGE
+ call UNwrite(ID__nc_one, 'YYYY', ipr_nc_one, 1, 1, 1, starta)
+ starta = mmarGE
+ call UNwrite(ID__nc_one, 'MM', ipr_nc_one, 1, 1, 1, starta)
+ starta = jdarGE
+ call UNwrite(ID__nc_one, 'DD', ipr_nc_one, 1, 1, 1, starta)
+ starta = jhurGE
+ call UNwrite(ID__nc_one, 'HH', ipr_nc_one, 1, 1, 1, starta)
+ starta = minuGE
+ call UNwrite(ID__nc_one, 'MIN', ipr_nc_one, 1, 1, 1, starta)
+ starta = jsecGE
+ call UNwrite(ID__nc_one, 'SS', ipr_nc_one, 1, 1, 1, starta)
+ ! + ************
+
+ if(ipr_nc_one == 1) &
+ call UNwrite(ID__nc_one, 'SLO', 1, mx, my, 1, slopTV)
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = GElonh(ii, jj) * 15. ! Hour->degrees
+ one2(ll) = GElatr(ii, jj) / degrad ! rad ->degree
+ one3(ll) = sh(ii, jj)
+ one4(ll) = real(isolSL(ii, jj)) ! REAL type
+ one5(ll) = x_one(ll)
+ one6(ll) = y_one(ll)
+ enddo
+ ! + ************
+ call UNwrite(ID__nc_one, 'lonMAR', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'latMAR', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'sh_MAR', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ call UNwrite(ID__nc_one, 'solTyp', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ call UNwrite(ID__nc_one, 'x_MAR', ipr_nc_one, ONEsta, 1, 1, one5(1:ONEsta))
+ call UNwrite(ID__nc_one, 'y_MAR', ipr_nc_one, ONEsta, 1, 1, one6(1:ONEsta))
+ ! + ************
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = lon_one(ll)
+ one2(ll) = lat_one(ll)
+ one3(ll) = sh_one(ll)
+ enddo
+ ! + ************
+ call UNwrite(ID__nc_one, 'lonAWS', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'latAWS', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'sh_AWS', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ ! + ************
+
+ Do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+
+ ! + 3.1 Computation of Relative Humidity
+ ! + ------------------------------------
+
+ do kk = 1, ONElev
+
+ epsilon = 0.622
+ q = qvDY(ii, jj, mz - kk + 1)
+ qst = qsat0D(tairDY(ii, jj, mz - kk + 1), &
+ sigma(mz - kk + 1), pstDY(ii, jj), ptopDY, 1)
+
+ r = q / max(epsi, 1.-q)
+ rst = qst / max(epsi, 1.-qst)
+
+ RH(ll, kk) = (r / (epsilon + r)) &
+ / max(epsi,(rst / (epsilon + rst))) * 100.
+
+ RH(ll, kk) = max(0., min(100., RH(ll, kk)))
+
+ ! + 3.2 Computation of wind direction and wind speed
+ ! + ------------------------------------------------
+ ! wd = 180 + ((atan2(U_moy / windspeed_moy, V_moy / windspeed_moy)) * (180 / Pi))
+
+ if(uairDY(ii, jj, mz - kk + 1) /= 0.0 .and. &
+ vairDY(ii, jj, mz - kk + 1) /= 0.0) then
+
+ uu(kk) = (GElonh(ii + 1, jj) - GElonh(ii, jj)) * conv / dx &
+ * a * cos(GElatr(ii, jj)) * &
+ uairDY(ii, jj, mz - kk + 1) + &
+ (GElonh(ii, jj + 1) - GElonh(ii, jj)) * conv / dx &
+ * a * cos(GElatr(ii, jj)) * &
+ vairDY(ii, jj, mz - kk + 1)
+
+ vv(kk) = (GElatr(ii + 1, jj) - GElatr(ii, jj)) / dx * a &
+ * uairDY(ii, jj, mz - kk + 1) + &
+ (GElatr(ii, jj + 1) - GElatr(ii, jj)) / dx * a &
+ * vairDY(ii, jj, mz - kk + 1)
+
+ WD(ll, kk) = 0.0
+
+ if(uu(kk) > 0.0 .and. vv(kk) >= 0.0) &
+ WD(ll, kk) = 3.0 * pi / 2.0 - atan(vv(kk) / uu(kk))
+ if(uu(kk) < 0.0 .and. vv(kk) >= 0.0) &
+ WD(ll, kk) = 5.0 * Pi / 2.0 - atan(vv(kk) / uu(kk))
+ if(uu(kk) < 0.0 .and. vv(kk) <= 0.0) &
+ WD(ll, kk) = 5.0 * Pi / 2.0 - atan(vv(kk) / uu(kk))
+ if(uu(kk) > 0.0 .and. vv(kk) <= 0.0) &
+ WD(ll, kk) = 3.0 * Pi / 2.0 - atan(vv(kk) / uu(kk))
+ if(uu(kk) == 0.0 .and. vv(kk) >= 0.0) &
+ WD(ll, kk) = Pi
+ if(uu(kk) == 0.0 .and. vv(kk) <= 0.0) &
+ WD(ll, kk) = 0.0
+ if(WD(ll, kk) > 2 * Pi) &
+ WD(ll, kk) = WD(ll, kk) - 2 * Pi
+
+ WD(ll, kk) = WD(ll, kk) * 180.0 / Pi
+
+ if(WD(ll, kk) < 0.0) &
+ WD(ll, kk) = WD(ll, kk) + 360.0
+
+ WD(ll, kk) = max(0.0, min(360.0, WD(ll, kk)))
+
+ WS(ll, kk) = sqrt(uairDY(ii, jj, mz - kk + 1) * uairDY(ii, jj, mz - kk + 1) + &
+ vairDY(ii, jj, mz - kk + 1) * vairDY(ii, jj, mz - kk + 1))
+
+ else
+ WS(ll, kk) = 0.0
+ WD(ll, kk) = 0.0
+ endif
+
+ enddo
+
+ enddo
+
+ ! + 3.3 Output
+ ! + ----------
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ do kk = 1, ONElev
+ one7(ll, kk) = tairDY(ii, jj, mz - kk + 1) - 273.15
+ one8(ll, kk) = uairDY(ii, jj, mz - kk + 1)
+ one9(ll, kk) = vairDY(ii, jj, mz - kk + 1)
+ one10(ll, kk) = qvDY(ii, jj, mz - kk + 1) * 1000.
+ enddo
+ enddo
+ ! + ************
+ call UNwrite(ID__nc_one, 'TT', ipr_nc_one, ONEsta, ONElev, 1, one7(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'UU', ipr_nc_one, ONEsta, ONElev, 1, one8(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'VV', ipr_nc_one, ONEsta, ONElev, 1, one9(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'WS', ipr_nc_one, ONEsta, ONElev, 1, WS(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'WD', ipr_nc_one, ONEsta, ONElev, 1, WD(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'QQ', ipr_nc_one, ONEsta, ONElev, 1, one10(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'RH', ipr_nc_one, ONEsta, ONElev, 1, RH(1:ONEsta, :))
+ ! + ************
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ do kk = 1, ONElev
+ ! pkta : *100kPa^cap -> K at 1000hPa standard pressure
+ one7(ll, kk) = pktaDY(ii, jj, mz - kk + 1) * 100.**cap
+ enddo
+ enddo
+
+ call UNwrite(ID__nc_one, 'PT', ipr_nc_one, ONEsta, ONElev, 1, one7(1:ONEsta, :))
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ do kk = 1, ONElev
+ one7(ll, kk) = TUkvm(ii, jj, mz - kk + 1)
+ one8(ll, kk) = ect_TE(ii, jj, mz - kk + 1)
+ one9(ll, kk) = gplvDY(ii, jj, mz - kk + 1) * grvinv
+ one10(ll, kk) = wairDY(ii, jj, mz - kk + 1)
+ enddo
+ enddo
+ ! + ************
+ call UNwrite(ID__nc_one, 'KZ', ipr_nc_one, ONEsta, ONElev, 1, one7(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'TKE', ipr_nc_one, ONEsta, ONElev, 1, one8(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'ZZ', ipr_nc_one, ONEsta, ONElev, 1, one9(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'WW', ipr_nc_one, ONEsta, ONElev, 1, one10(1:ONEsta, :))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ do kk = 1, ONElev
+ one7(ll, kk) = qiHY(ii, jj, mz - kk + 1) * 1000.
+ one8(ll, kk) = qwHY(ii, jj, mz - kk + 1) * 1000.
+ one9(ll, kk) = qsHY(ii, jj, mz - kk + 1) * 1000.
+ one10(ll, kk) = qrHY(ii, jj, mz - kk + 1) * 1000.
+ enddo
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'QI', ipr_nc_one, ONEsta, ONElev, 1, one7(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'QW', ipr_nc_one, ONEsta, ONElev, 1, one8(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'QS', ipr_nc_one, ONEsta, ONElev, 1, one9(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'QR', ipr_nc_one, ONEsta, ONElev, 1, one10(1:ONEsta, :))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = tairSL(ii, jj) - 273.15
+ one2(ll) = pstDY(ii, jj) * 10.
+ one3(ll) = (rainHY(ii, jj) - one0rnf(ll)) * 1000.
+ one0rnf(ll) = rainHY(ii, jj)
+ one4(ll) = (snowHY(ii, jj) + crysHY(ii, jj) - one0snf(ll)) * 1000.
+ one0snf(ll) = snowHY(ii, jj) + crysHY(ii, jj)
+ one5(ll) = rainCA(ii, jj) * 1000.
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'ST', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'SP', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'rnf', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ call UNwrite(ID__nc_one, 'snf', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ call UNwrite(ID__nc_one, 'CP', ipr_nc_one, ONEsta, 1, 1, one5(1:ONEsta))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = Radsol(ii, jj)
+ one2(ll) = Rad_IR(ii, jj)
+ one3(ll) = hsenSL(ii, jj)
+ one4(ll) = hlatSL(ii, jj)
+ one5(ll) = firmSL(ii, jj)
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'SWD', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'LWD', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'LWU', ipr_nc_one, ONEsta, 1, 1, one5(1:ONEsta))
+ call UNwrite(ID__nc_one, 'SHF', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ call UNwrite(ID__nc_one, 'LHF', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = albeSL(ii, jj)
+ one2(ll) = cld_SL(ii, jj)
+ one3(ll) = runoTV(ii, jj) - one0rof(ll)
+ one0rof(ll) = runoTV(ii, jj)
+ one4(ll) = evapTV(ii, jj) - one0evp(ll)
+ one0evp(ll) = evapTV(ii, jj)
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'AL', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'CC', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'rof', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ call UNwrite(ID__nc_one, 'evp', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = 0.0; one2(ll) = 0.0; one3(ll) = 0.0
+ do k = mzabso + 1, mz
+ one3(ll) = (pstDY(ii, jj) * sigma(k) + ptopDY) &
+ / (ra * tairDY(ii, jj, k) * (1.+.608 * qvDY(ii, jj, k))) &
+ * (gpmiDY(ii, jj, k) - gpmiDY(ii, jj, k + 1))
+ one1(ll) = one1(ll) + one3(ll) * qwHY(ii, jj, k)
+ one2(ll) = one2(ll) + one3(ll) * qiHY(ii, jj, k)
+ enddo
+ one4(ll) = 1.5 * (one1(ll) / 20.d-6 + one2(ll) / 40.d-6) * grvinv
+ enddo
+
+ ! + *******
+ call UNwrite(ID__nc_one, 'COD', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ ! + *******
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = SLlmo(ii, jj)
+ one2(ll) = SLuus(ii, jj)
+ one3(ll) = SLuts(ii, jj)
+ one4(ll) = SLuqs(ii, jj)
+ one5(ll) = SaltSN(ii, jj, 1)
+ enddo
+
+ ! + *******
+ call UNwrite(ID__nc_one, 'LMO', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'UUS', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'UTS', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ call UNwrite(ID__nc_one, 'UQS', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ call UNwrite(ID__nc_one, 'UUSsalt', ipr_nc_one, ONEsta, 1, 1, one5(1:ONEsta))
+ ! + *******
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ SL_wge = 0.0; SLlwge = 0.0; SLuwge = 0.0
+
+ ! + *****
+ call WGustE
+ ! + *****
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = SL_wge(ii, jj)
+ one2(ll) = SLlwge(ii, jj)
+ one3(ll) = SLuwge(ii, jj)
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'WGE', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'WGL', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'WGU', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = SL_z0(ii, jj, 1)
+ one2(ll) = SL_r0(ii, jj, 1)
+ one3(ll) = SWaSNo(ii, jj, 1)
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'Z0', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'R0', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'SWA', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ zn1IB(i, j, k) = 1.
+ zn2IB(i, j, k) = 0.
+ zn3IB(i, j, k) = 0.
+ wet_IB(i, j, k) = 0.
+ enddo
+ enddo
+ enddo
+
+ do kk = nsno, 1, -1
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ zn3IB(i, j, k) = dzsSNo(i, j, k, kk) + zn3IB(i, j, k)
+ wet_IB(i, j, k) = rosSNo(i, j, k, kk) * dzsSNo(i, j, k, kk) &
+ * 1.d3 / ro_Wat * (1.+0.*wasSNo(i, j, k, kk)) &
+ + wet_IB(i, j, k)
+ zn1IB(i, j, k) = zn1IB(i, j, k) &
+ * max(zero, sign(unun, &
+ ro_ice - 20.-rosSNo(i, j, k, kk)))
+ zn2IB(i, j, k) = dzsSNo(i, j, k, kk) * zn1IB(i, j, k) &
+ + zn2IB(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ wet_IB(i, j, k) = wet_IB(i, j, k) + SWaSNo(i, j, k)
+ zn2IB(i, j, k) = zn2IB(i, j, k) * (1.-zn1IB(i, j, k))
+ zn1IB(i, j, k) = zn3IB(i, j, k) - zn0IB(i, j, k)
+ mbIB(i, j, k) = wet_IB(i, j, k) - mb0IB(i, j, k)
+ enddo
+ enddo
+ enddo
+
+ do ll = 1, ONEsta
+ ii = i_one(ll)
+ jj = j_one(ll)
+ one1(ll) = zn1IB(ii, jj, 1)
+ one2(ll) = zn2IB(ii, jj, 1)
+ one3(ll) = zn3IB(ii, jj, 1)
+ one4(ll) = mbIB(ii, jj, 1)
+ one5(ll) = real(nssSNo(ii, jj, 1))
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'ZN', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'ZN1', ipr_nc_one, ONEsta, 1, 1, one1(1:ONEsta))
+ call UNwrite(ID__nc_one, 'ZN2', ipr_nc_one, ONEsta, 1, 1, one2(1:ONEsta))
+ call UNwrite(ID__nc_one, 'ZN3', ipr_nc_one, ONEsta, 1, 1, one3(1:ONEsta))
+ call UNwrite(ID__nc_one, 'MB', ipr_nc_one, ONEsta, 1, 1, one4(1:ONEsta))
+ call UNwrite(ID__nc_one, 'NSsn', ipr_nc_one, ONEsta, 1, 1, one5(1:ONEsta))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta; do nn = 1, nsno
+ ii = i_one(ll); jj = j_one(ll)
+ if(nn <= nssSNo(ii, jj, 1)) then
+ one11(ll, nn) = dzsSNo(ii, jj, 1, nssSNo(ii, jj, 1) - nn + 1)
+ one12(ll, nn) = rosSNo(ii, jj, 1, nssSNo(ii, jj, 1) - nn + 1)
+ else
+ one11(ll, nn) = NF_FILL_REAL
+ one12(ll, nn) = NF_FILL_REAL
+ endif
+ enddo;
+ enddo
+ ! + ************
+ call UNwrite(ID__nc_one, 'DZsn', ipr_nc_one, ONEsta, nsno, 1, one11(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'ROsn', ipr_nc_one, ONEsta, nsno, 1, one12(1:ONEsta, :))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta; do nn = 1, nsno
+ ii = i_one(ll); jj = j_one(ll)
+ if(nn <= nssSNo(ii, jj, 1)) then
+ one11(ll, nn) = g1sSNo(ii, jj, 1, nssSNo(ii, jj, 1) - nn + 1)
+ one12(ll, nn) = g2sSNo(ii, jj, 1, nssSNo(ii, jj, 1) - nn + 1)
+ else
+ one11(ll, nn) = NF_FILL_REAL
+ one12(ll, nn) = NF_FILL_REAL
+ endif
+ enddo;
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'G1sn', ipr_nc_one, ONEsta, nsno, 1, one11(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'G2sn', ipr_nc_one, ONEsta, nsno, 1, one12(1:ONEsta, :))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta; do nn = 1, nsno
+ ii = i_one(ll); jj = j_one(ll)
+ if(nn <= nssSNo(ii, jj, 1)) then
+ one11(ll, nn) = tisSNo(ii, jj, 1, nn) - TfSnow
+ one12(ll, nn) = wasSNo(ii, jj, 1, nn)
+ else
+ one11(ll, nn) = NF_FILL_REAL
+ one12(ll, nn) = NF_FILL_REAL
+ endif
+ enddo;
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'TIsn', ipr_nc_one, ONEsta, nsno, 1, one11(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'WAsn', ipr_nc_one, ONEsta, nsno, 1, one12(1:ONEsta, :))
+ ! + ************
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ do ll = 1, ONEsta; do nn = 1, nsol + 1
+ ii = i_one(ll); jj = j_one(ll)
+ one14(ll, nn) = TsolTV(ii, jj, 1, nn) - TfSnow
+ one15(ll, nn) = Eta_TV(ii, jj, 1, nn)
+ enddo;
+ enddo
+
+ ! + ************
+ call UNwrite(ID__nc_one, 'SLT', ipr_nc_one, ONEsta, nsol + 1, 1, one14(1:ONEsta, :))
+ call UNwrite(ID__nc_one, 'SLQ', ipr_nc_one, ONEsta, nsol + 1, 1, one15(1:ONEsta, :))
+ ! + ************
+
+1000 continue
+
+ ! + 3.4 NetCDF File Closure
+ ! + -----------------------
+
+ if(ID__nc_one /= -1) then
+
+ ! + ************
+ call UNclose(ID__nc_one)
+ ! + ************
+
+ endif
+
+ WKxy1 = 0; WKxy2 = 0; WKxy3 = 0; WKxy4 = 0
+
+endsubroutine OUTone
+
+subroutine WGustE
+ ! +-------------------------------------------------------------------+
+ ! | |
+ ! | MAR GUSTS 14-09-2001 MAR |
+ ! | subroutine WGustE computes diagnostic Wind Gust Estimates |
+ ! | |
+ ! +-------------------------------------------------------------------+
+ ! | |
+ ! | This routine aims at estimating wind gusts. It also includes the |
+ ! | computation of a bounding interval around the estimate which aims |
+ ! | to contain with a high probability observed gusts. |
+ ! | |
+ ! | Ref. : Brasseur O., MWR, 129, 5-25. |
+ ! | ^^^^^^^ |
+ ! | |
+ ! | Input : - uairDY : U-wind |
+ ! | ^^^^^^^ - vairDY : V-wind |
+ ! | - wairDY : W-wind |
+ ! | - tairDY : REAL temperature |
+ ! | - tairSL : surface temperature |
+ ! | - qvDY : specific humidity |
+ ! | - qwHY : cloud dropplets |
+ ! | - qiHY : ice crystals |
+ ! | - qrHY : rain |
+ ! | - qsHY : snow |
+ ! | - SLuts : surface heat flux |
+ ! | - ect_TE : turbulent kinetic energy |
+ ! | - zzDY : level heights |
+ ! | - sh : surface elevation |
+ ! | - sigma : sigma levels |
+ ! | - pstDY : pressure depth |
+ ! | - ptopDY : pressure at the top of the model |
+ ! | |
+ ! | Output: - SL_wge : gust estimate (m/s) |
+ ! | ^^^^^^^ - SLlwge : lower bound of the bounding interval (m/s) |
+ ! | - SLuwge : upper bound of the bounding interval (m/s) |
+ ! | |
+ ! +-------------------------------------------------------------------+
+
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_hy
+ use mar_te
+ use mar_sl
+
+ implicit none
+
+ ! +---Local variables
+ ! + ---------------
+
+ integer i, j, k, l
+ INTEGER lev_up, lev_dw, top_bl, kzi
+
+ real int_buo, local_tke, tke_min, aux0, aux1, aux2
+ real coeff, dtkemin, ra, cp, gravit, cap
+ real ENERGY_low, ENERGY_est
+ real coeffmin, srf_TKE, wstar, rzero
+
+ real tetae(mz), tetav(mz), buoy(mz), normv(mz), filECT(mz)
+ real mean_tke(mz), tmpECT(mz)
+
+ ! +---Data
+ ! + ----
+
+ DATA dtkemin/1.e-5/
+ DATA coeffmin/0.01/
+ DATA cap/0.28586/
+ DATA ra/287./
+ DATA cp/1004./
+ DATA gravit/9.81/
+ DATA rzero/0.0/
+
+ ! + ====================================================
+
+ do j = 1, my
+ do i = 1, mx
+
+ ! + ====================================================
+
+ do k = 1, mz
+
+ ! +---Compute Virtual and Equivalent Potential Temperature
+ ! + ----------------------------------------------------
+
+ tetav(k) = tairDY(i, j, k) &
+ * (100./(pstDY(i, j) * sigma(k) + ptopDY))**cap &
+ * (1.+0.608 * qvDY(i, j, k) - qwHY(i, j, k) - qiHY(i, j, k) &
+ - qrHY(i, j, k) - qsHY(i, j, k))
+ ! + ^^^ Virtual potential temperature
+
+ ! +---Compute wind norm
+ ! + -----------------
+
+ normv(k) = SQRT(uairDY(i, j, k) * uairDY(i, j, k) &
+ + vairDY(i, j, k) * vairDY(i, j, k) &
+ + wairDY(i, j, k) * wairDY(i, j, k) / 10000.)
+
+ enddo
+
+ ! +---Compute Integrated Buoyancy
+ ! + ---------------------------
+
+ k = mz
+ int_buo = (0.5 * tetav(k) + 0.5 * tetav(k - 1) &
+ - 0.5 * tetav(mz) - 0.5 * tetav(mz - 1)) * gravit &
+ / (0.5 * tetav(mz) + 0.5 * tetav(mz - 1)) / 2. &
+ *(gplvDY(i, j, k - 1) - gplvDY(i, j, k)) / gravit
+ int_buo = MAX(0., int_buo)
+ buoy(k) = int_buo
+
+ k = mz - 1
+ int_buo = int_buo - (0.5 * tetav(k) + 0.5 * tetav(k - 1) &
+ - 0.5 * tetav(mz) - 0.5 * tetav(mz - 1)) * gravit &
+ / (0.5 * tetav(mz) + 0.5 * tetav(mz - 1)) / 2. &
+ *(gplvDY(i, j, k - 1) - gplvDY(i, j, k)) / gravit
+ int_buo = MAX(0., int_buo)
+ buoy(k) = int_buo
+
+ do k = mz, 2, -1
+
+ int_buo = int_buo - (0.5 * tetav(k) + 0.5 * tetav(k - 1) &
+ - 0.5 * tetav(mz) - 0.5 * tetav(mz - 1)) * gravit &
+ / (0.5 * tetav(mz) + 0.5 * tetav(mz - 1)) / 2. &
+ *(gplvDY(i, j, k - 1) - gplvDY(i, j, k)) / gravit
+ buoy(k) = int_buo
+
+ enddo
+
+ ! +---Filtering of turbulent kinetic energy
+ ! + -------------------------------------
+
+ tmpECT(1) = ect_TE(i, j, 1)
+ tmpECT(mz) = ect_TE(i, j, mz)
+ filECT(1) = ect_TE(i, j, 1)
+ filECT(mz) = ect_TE(i, j, mz)
+
+ do k = 2, mz - 1
+ if(i /= 1 .and. i /= mx .and. j /= 1 .and. j /= my) then
+ tmpECT(k) = (4.*ect_TE(i, j, k) &
+ + 2.*ect_TE(i - 1, j, k) + 2.*ect_TE(i + 1, j, k) &
+ + 2.*ect_TE(i, j - 1, k) + 2.*ect_TE(i, j + 1, k) &
+ + 1.*ect_TE(i - 1, j - 1, k) + 1.*ect_TE(i - 1, j + 1, k) &
+ + 1.*ect_TE(i + 1, j - 1, k) + 1.*ect_TE(i + 1, j + 1, k)) / 16.
+ endif
+ enddo
+
+ do k = 2, mz - 1
+ aux1 = (gplvDY(i, j, k - 1) - gplvDY(i, j, k)) / gravit
+ aux2 = (gplvDY(i, j, k) - gplvDY(i, j, k + 1)) / gravit
+ filECT(k) = 0.25 * (2.*tmpECT(k) &
+ + 2.*(aux2 / (aux1 + aux2)) * tmpECT(k - 1) &
+ + 2.*(aux1 / (aux1 + aux2)) * tmpECT(k + 1))
+ enddo
+
+ ! +---Determination of mean tke below level k
+ ! + - - - - - - - - - - - - - - - - - - - -
+
+ aux1 = 0.
+ aux2 = 0.
+
+ do k = mz - 1, 2, -1
+ aux1 = aux1 + (gplvDY(i, j, k) + gplvDY(i, j, k + 1)) / 2. &
+ *filECT(k) &
+ * (gplvDY(i, j, k) - gplvDY(i, j, k + 1))
+ aux2 = aux2 + (gplvDY(i, j, k) + gplvDY(i, j, k + 1)) / 2. &
+ *(gplvDY(i, j, k) - gplvDY(i, j, k + 1))
+ enddo
+
+ mean_tke(k) = aux1 / aux2
+
+ ! +---Compute wstar
+ ! + -------------
+
+#if(WW)
+ wstar = MAX(zero,(-gravit * zi__TE(i, j) / 290.*SLuts(i, j))**(1./3.))
+#endif
+
+ ! +---Evaluation of Gust Wind Speed
+ ! + -----------------------------
+
+ ! +---Initial value
+ ! + - - - - - - -
+
+ SL_wge(i, j) = MAX(SL_wge(i, j), normv(mz))
+ SLuwge(i, j) = MAX(SLuwge(i, j), normv(mz))
+ SLlwge(i, j) = MAX(SLlwge(i, j), normv(mz))
+
+ lev_dw = 1
+ lev_up = mz
+ top_bl = mz
+
+ do k = mz - 1, 2, -1
+
+ ! +---Determination of the Top of Boundary Layer
+ ! + - - - - - - - - - - - - - - - - - - - - -
+
+ coeff = coeffmin &
+ + 0.1 * ((gplvDY(i, j, k) - gplvDY(i, j, mz + 1)) &
+ / gravit - 2000.) / 1000.
+
+ tke_min = coeff * (filECT(mz) + filECT(mz - 1)) * 0.5
+
+ if(top_bl == mz .and. &
+ filECT(k + 1) > tke_min .and. &
+ filECT(k) <= tke_min) top_bl = k
+
+ ! +---Upper bound on Gust Wind Speed
+ ! + - - - - - - - - - - - - - - - -
+
+ local_tke = (filECT(k) + filECT(k - 1)) * 0.5
+
+ if(local_tke > tke_min .and. top_bl == mz) then
+
+ if(SLuwge(i, j) < normv(k)) then
+ SLuwge(i, j) = MAX(SLuwge(i, j), normv(k))
+ ! + ^^^ Max Wind Speed (m/s)
+ lev_up = k
+ ! + ^^^ Level of Max Wind Speed (m/s)
+ endif
+
+ endif
+
+ ! +---Lower bound on Wind Gust
+ ! + - - - - - - - - - - - -
+ ! buoy : Sink
+ ENERGY_low = 2.5 / 11.*filECT(k) + buoy(k)
+ ! +
+ if(ENERGY_low >= 0.) then
+ SLlwge(i, j) = MAX(normv(k), SLlwge(i, j))
+ ! + ^^^ Min Wind Speed (m/s)
+ lev_dw = k
+ endif
+
+ ! +---Estimate of Wind Gust
+ ! + - - - - - - - - - - -
+ ! buoy : Sink
+ ENERGY_est = MAX(mean_tke(k), 2.5 / 11.*filECT(k)) + buoy(k)
+
+ if(ENERGY_est >= 0.) then
+ SL_wge(i, j) = MAX(0.5 * (normv(k) + normv(k - 1)), SL_wge(i, j))
+ endif
+
+ ENDdo ! {Loop on k}
+
+ ! + ====================================================
+ ! +
+ ENDdo ! {Loop on i}
+ ENDdo ! {Loop on j}
+ ! +
+ ! + ====================================================
+
+ return
+endsubroutine WGustE
diff --git a/MAR/code_mar/sisvat.f90 b/MAR/code_mar/sisvat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..65b0f3402edcb6cbadc1b1f3cfa16702c19a0cac
--- /dev/null
+++ b/MAR/code_mar/sisvat.f90
@@ -0,0 +1,2386 @@
+#include "MAR_pp.def"
+subroutine SISVAT(itPhys)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT 10-nov-2021 MAR |
+ ! | subroutine SISVAT contains the fortran 77 code of the |
+ ! | Soil/Ice Snow Vegetation Atmosphere Transfer Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: daHost : Date Host Model |
+ ! | ^^^^^ |
+ ! | |
+ ! | INPUT: LSmask : 1: Land MASK |
+ ! | ^^^^^ 0: Sea MASK |
+ ! | ivgtSV = 0,...,12: Vegetation Type |
+ ! | isotSV = 0,...,12: Soil Type |
+ ! | 0: Water, Liquid (Sea, Lake) |
+ ! | 12: Water, Solid (Ice) |
+ ! | |
+ ! | INPUT: coszSV : Cosine of the Sun Zenithal Distance [-] |
+ ! | ^^^^^ sol_SV : Surface Downward Solar Radiation [W/m2] |
+ ! | IRd_SV : Surface Downward Longwave Radiation [W/m2] |
+ ! | drr_SV : Rain Intensity [kg/m2/s] |
+ ! | dsn_SV : Snow Intensity [mm w.e./s] |
+ ! | dsnbSV : Snow Intensity, Drift Fraction [-] |
+ ! | dbs_SV : Drift Amount [mm w.e.] |
+ ! | za__SV : Surface Boundary Layer (SBL) Height [m] |
+ ! | VV__SV :(SBL Top) Wind Velocity [m/s] |
+ ! | VV10SV : 10-m Wind Velocity [m/s] |
+ ! | TaT_SV : SBL Top Temperature [K] |
+ ! | rhT_SV : SBL Top Air Density [kg/m3] |
+ ! | QaT_SV : SBL Top Specific Humidity [kg/kg] |
+ ! | qsnoSV : SBL Mean Snow Content [kg/kg] |
+ ! | LAI0SV : Leaf Area Index [-] |
+ ! | glf0SV : Green Leaf Fraction [-] |
+ ! | alb0SV : Soil Basic Albedo [-] |
+ ! | slopSV : Surface Slope [-] |
+ ! | dt__SV : Time Step [s] |
+ ! | |
+ ! | INPUT / isnoSV = total Nb of Ice/Snow Layers |
+ ! | OUTPUT: ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer |
+ ! | ^^^^^^ iiceSV = total Nb of Ice Layers |
+ ! | istoSV = 0,...,5 : Snow History (see istdSV data) |
+ ! | |
+ ! | INPUT / alb_SV : Surface-Canopy Albedo [-] |
+ ! | OUTPUT: emi_SV : Surface-Canopy Emissivity [-] |
+ ! | ^^^^^^ IRs_SV : Soil IR Flux (negative) [W/m2] |
+ ! | LMO_SV : Monin-Obukhov Scale [m] |
+ ! | us__SV : Friction Velocity [m/s] |
+ ! | uts_SV : Temperature Turbulent Scale [m/s] |
+ ! | uqs_SV : Specific Humidity Velocity [m/s] |
+ ! | uss_SV : Blowing Snow Turbulent Scale [m/s] |
+ ! | usthSV : Blowing Snow Erosion Threshold [m/s] |
+ ! | Z0m_SV : Momentum Roughness Length [m] |
+ ! | Z0mmSV : Momentum Roughness Length (time mean) [m] |
+ ! | Z0mnSV : Momentum Roughness Length (instantaneous)[m] |
+ ! | Z0SaSV : Sastrugi Roughness Length [m] |
+ ! | Z0e_SV : Erosion Snow Roughness Length [m] |
+ ! | Z0emSV : Erosion Snow Roughness Length (time mean) [m] |
+ ! | Z0enSV : Erosion Snow Roughness Length (instantaneous)[m] |
+ ! | Z0roSV : Subgrid Topo Roughness Length [m] |
+ ! | Z0h_SV : Heat Roughness Length [m] |
+ ! | snCaSV : Canopy Snow Thickness [mm w.e.] |
+ ! | rrCaSV : Canopy Water Content [kg/m2] |
+ ! | psivSV : Leaf Water Potential [m] |
+ ! | TvegSV : Canopy Temperature [K] |
+ ! | TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+ ! | & Snow Temperatures (layers 1,2,...,nsno) [K] |
+ ! | ro__SV : Soil/Snow Volumic Mass [kg/m3] |
+ ! | eta_SV : Soil/Snow Water Content [m3/m3] |
+ ! | G1snSV : snow dendricity/sphericity |
+ ! | G2snSV : snow sphericity/grain size |
+ ! | dzsnSV : Snow Layer Thickness [m] |
+ ! | agsnSV : Snow Age [day] |
+ ! | BufsSV : Snow Buffer Layer [kg/m2] .OR. [mm] |
+ ! | BrosSV : Snow Buffer Layer Density [kg/m3] |
+ ! | BG1sSV : Snow Buffer Layer Dendricity / Sphericity [-] |
+ ! | BG2sSV : Snow Buffer Layer Sphericity / Size [-] [0.1 mm] |
+ ! | rusnSV : Surficial Water [kg/m2] .OR. [mm] |
+ ! | |
+ ! | OUTPUT: no__SV : OUTPUT file Unit Number [-] |
+ ! | ^^^^^^ i___SV : OUTPUT point i Coordinate [-] |
+ ! | j___SV : OUTPUT point j Coordinate [-] |
+ ! | n___SV : OUTPUT point n Coordinate [-] |
+ ! | lwriSV : OUTPUT point vec Index [-] |
+ ! | |
+ ! | OUTPUT: IRu_SV : Upward IR Flux (+, upw., effective) [K] |
+ ! | ^^^^^^ hSalSV : Saltating Layer Height [m] |
+ ! | qSalSV : Saltating Snow Concentration [kg/kg] |
+ ! | RnofSV : RunOFF Intensity [kg/m2/s] |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | NLaysv = New Snow Layer Switch [-] |
+ ! | albisv : Snow/Ice/Water/Soil Integrated Albedo [-] |
+ ! | SoCasv : Absorbed Solar Radiation by Canopy (Normaliz)[-] |
+ ! | SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
+ ! | tau_sv : Fraction of Radiation transmitted by Canopy [-] |
+ ! | TBr_sv : Brightness Temperature [K] |
+ ! | IRupsv : Upward IR Flux (-, upw.) [W/m2] |
+ ! | IRv_sv : Vegetation IR Flux [W/m2] |
+ ! | rrMxsv : Canopy Maximum Intercepted Rain [kg/m2] |
+ ! | Sigmsv : Canopy Ventilation Factor [-] |
+ ! | ram_sv : Aerodynamic Resistance for Momentum [s/m] |
+ ! | rah_sv : Aerodynamic Resistance for Heat [s/m] |
+ ! | HSv_sv : Vegetation Sensible Heat Flux [W/m2] |
+ ! | HLv_sv : Vegetation Latent Heat Flux [W/m2] |
+ ! | Rootsv : Root Water Pump [kg/m2/s] |
+ ! | Evp_sv : Evaporation [kg/m2] |
+ ! | EvT_sv : Evapotranspiration [kg/m2] |
+ ! | HSs_sv : Surface Sensible Heat Flux + => absorb.[W/m2] |
+ ! | HLs_sv : Surface Latent Heat Flux + => absorb.[W/m2] |
+ ! | Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] |
+ ! | Tsrfsv : Surface Temperature [K] |
+ ! | LAI_sv : Leaf Area Index (snow included) [-] |
+ ! | LAIesv : Leaf Area Index (effective / transpiration) [-] |
+ ! | glf_sv : Green Leaf Fraction of NOT fallen Leaves [-] |
+ ! | sEX_sv : Verticaly Integrated Extinction Coefficient [-] |
+ ! | LSdzsv : Vertical Discretization Factor [-] |
+ ! | = 1. Soil |
+ ! | = 1000. Ocean |
+ ! | z_snsv : Snow Pack Thickness [m] |
+ ! | zzsnsv : Snow Pack Thickness [m] |
+ ! | albssv : Soil Albedo [-] |
+ ! | Evg_sv : Soil+Vegetation Emissivity [-] |
+ ! | Eso_sv : Soil+Snow Emissivity [-] |
+ ! | psi_sv : Soil Water Potential [m] |
+ ! | Khydsv : Soil Hydraulic Conductivity [m/s] |
+ ! | |
+ ! | ETVg_d : VegetationEnergy Power Forcing [W/m2] |
+ ! | ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] |
+ ! | ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] |
+ ! | ETSo_d : Snow/Soil Energy Power Forcing [W/m2] |
+ ! | EqSn_0 : Snow Energy, before Phase Change [J/m2] |
+ ! | EqSn_1 : Snow Energy, after Phase Change [J/m2] |
+ ! | EqSn_d : Snow Energy, net Forcing [J/m2] |
+ ! | Enrsvd : SVAT Energy Power Forcing [W/m2] |
+ ! | Enrbal : SVAT Energy Balance [W/m2] |
+ ! | Wats_0 : Soil Water, before Forcing [mm] |
+ ! | Wats_1 : Soil Water, after Forcing [mm] |
+ ! | Wats_d : Soil Water Forcing [mm] |
+ ! | SIWm_0 : Snow initial Mass [mm w.e.] |
+ ! | SIWm_1 : Snow final Mass [mm w.e.] |
+ ! | SIWa_i : Snow Atmos. initial Forcing [mm w.e.] |
+ ! | SIWa_f : Snow Atmos. final Forcing(noConsumed)[mm w.e.] |
+ ! | SIWe_i : SnowErosion initial Forcing [mm w.e.] |
+ ! | SIWe_f : SnowErosion final Forcing(noConsumed)[mm w.e.] |
+ ! | SIsubl : Snow sublimed/deposed Mass [mm w.e.] |
+ ! | SImelt : Snow Melted Mass [mm w.e.] |
+ ! | SIrnof : Surficial Water + Run OFF Change [mm w.e.] |
+ ! | SIvAcr : Sea-Ice vertical Acretion [mm w.e.] |
+ ! | Watsvd : SVAT Water Forcing [mm] |
+ ! | Watbal : SVAT Water Balance [W/m2] |
+ ! | |
+ ! | dsn_Ca,snCa_n : Snow Contribution to the Canopy[m w.e.] |
+ ! | drr_Ca,rrCa_n,drip: Rain Contribution to the Canopy [kg/m2] |
+ ! | vk2 : Square of Von Karman Constant [-] |
+ ! | sqrCm0 : Factor of Neutral Drag Coeffic.Momentum [s/m] |
+ ! | sqrCh0 : Factor of Neutral Drag Coeffic.Heat [s/m] |
+ ! | EmiVeg : Vegetation Emissivity [-] |
+ ! | EmiSol : Soil Emissivity [-] |
+ ! | EmiSno : Snow Emissivity [-] |
+ ! | EmiWat : Water Emissivity [-] |
+ ! | Z0mSea : Sea Roughness Length [m] |
+ ! | Z0mLnd : Land Roughness Length [m] |
+ ! | sqrrZ0 : u*t/u* |
+ ! | f_eff : Marticorena & B. 1995 JGR (20) |
+ ! | A_Fact : Fundamental * Roughness |
+ ! | Z0mBSn : BSnow Roughness Length [m] |
+ ! | Z0mBS0 : Mimimum BSnow Roughness Length (blown* ) [m] |
+ ! | Z0m_Sn : Snow Roughness Length (surface) [m] |
+ ! | Z0m_S0 : Mimimum Snow Roughness Length [m] |
+ ! | Z0m_S1 : Maximum Snow Roughness Length [m] |
+ ! | Z0_GIM : Minimum GIMEX Roughness Length [m] |
+ ! | Z0_ICE : Sea Ice ISW Roughness Length [m] |
+ ! | |
+ ! | # TUNING PARAMETERS : |
+ ! | # OPTIONS: #BS: Wind Dependant Roughness Length of Snow |
+ ! | # ^^^^^^^ #ZS: Wind Dependant Roughness Length of Sea |
+ ! | # #FL: Dead Leaves are assumed to been fallen |
+ ! | # #RS: Z0h = Z0m / 100 over the ocean |
+ ! | # #US: u* computed from aerodynamic resistance |
+ ! | # #WV: OUTPUT |
+ ! | # #WR: OUTPUT for Verification |
+ ! | # #SR: Variable Tracing |
+ ! | # #CP: Col de Porte Turbulence Parameterization |
+ ! | # #GL: Greenland Parameterization |
+ ! | |
+ ! | |
+ ! | TUNING PARAMETER: |
+ ! | ^^^^^^^^^^^^^^^^ |
+ ! | z0soil : Soil Surface averaged Bumps Height (see _qSo)[m] |
+ ! | |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SISVAT_iii_jjj_n | #E0: OUTPUT on ASCII File (SISVAT Variables) |
+ ! | # | Energy Budg. Verif.: Soil+(Sea-Ice)+Snow |
+ ! | # |(#E0 MUST BE PREPROCESSED BEFORE #e1 & #e2 !) |
+ ! | # SISVAT_iii_jjj_n | #m0: OUTPUT/Verification: H2O Conservation |
+ ! | | |
+ ! | # stdout | #s0: OUTPUT of Snow Buffer Layer |
+ ! | | unit 6, subroutine SISVAT **ONLY** |
+ ! | # stdout | #sb: OUTPUT of Snow Erosion |
+ ! | | unit 6, subroutine SISVAT_BSn **ONLY** |
+ ! | # stdout | #sz: OUTPUT of Roughness Length & Drag Coeff. |
+ ! | | unit 6, subroutine SISVAT **ONLY** |
+ ! | # stdout | #wz: OUTPUT of Roughness Length (Blown Snow) |
+ ! | | unit 6, subroutines SISVAT, PHY_SISVAT |
+ ! | |
+ ! | SUGGESTIONS of MODIFICATIONS: see lines beginning with "C +!!!" |
+ ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mar_sv
+ use marlsv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use mardim
+ use mar_ge
+ use marysv
+ use margrd
+#if(CP)
+ use marcdp
+#endif
+
+ implicit none
+
+ ! +--Internal Variables
+ ! + ==================
+
+ ! TBr_sv : Brightness Temperature
+ real TBr_sv(klonv)
+ ! IRdwsv : DOWNward IR Flux
+ real IRdwsv(klonv)
+ ! IRupsv : UPward IR Flux
+ real IRupsv(klonv)
+ ! d_Bufs : Buffer Snow Layer Increment
+ real d_Bufs, Bufs_N
+ ! Buf_ro : Buffer Snow Layer Density
+ real Buf_ro, Bros_N
+ ! BufPro : Buffer Snow Layer Density
+ real BufPro
+ ! dt__SV2 : saved dt
+ real dt__SV2
+ ! Buf_G1 : Buffer Snow Layer Dendr/Sphe[-]
+ real Buf_G1, BG1__N
+ ! Buf_G2 : Buffer Snow Layer Spher/Size[-]
+ real Buf_G2, BG2__N
+ ! Bdzssv : Buffer Snow Layer Thickness
+ real Bdzssv(klonv)
+ ! z_snsv : Snow-Ice, current Thickness
+ real z_snsv(klonv)
+
+ ! +--Energy Budget
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ ! ETVg_d : VegetationPower, Forcing
+ real ETVg_d(klonv)
+ ! ETSo_0 : Soil/Snow Power, before Forcing
+ real ETSo_0(klonv)
+ ! ETSo_1 : Soil/Snow Power, after Forcing
+ real ETSo_1(klonv)
+ ! ETSo_d : Soil/Snow Power, Forcing
+ real ETSo_d(klonv)
+#if(e1)
+ ! EqSn_0 : Snow Energy, befor Phase Change
+ real EqSn_0(klonv)
+ ! EqSn_1 : Snow Energy, after Phase Change
+ real EqSn_1(klonv)
+ ! EqSn_d : Energy in Excess
+ real EqSn_d(klonv)
+#endif
+
+ ! +--Water (Mass) Budget
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ ! Wats_0 : Soil Water, before Forcing
+ real Wats_0(klonv)
+ ! Wats_1 : Soil Water, after Forcing
+ real Wats_1(klonv)
+ ! Wats_d : Soil Water, Forcing
+ real Wats_d(klonv)
+
+#if(m1)
+ ! +--Snow/Ice(Mass) Budget
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ ! SIsubl : Snow Sublimed/Deposed Mass
+ real SIsubl(klonv)
+ ! SImelt : Snow Melted Mass
+ real SImelt(klonv)
+ ! SIrnof : Local Surficial Water + Run OFF
+ real SIrnof(klonv)
+#endif
+
+ ! +--Sea-Ice (Mass) Budget
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ ! SIvAcr : Sea-Ice Vertical Acretion
+ real SIvAcr(klonv)
+
+ ! +--Local
+ ! + -----
+
+#if(MT)
+ ! Garrat : SBL Scheme Switch
+ logical Garrat
+#endif
+ ! SepLab : OUTPUT ASCII File Labels
+ character * 1 SepLab
+ character * 6 FilLab
+ character * 16 FilNam
+ common / SISVAT_loc_abc / SepLab, FilLab
+ ! FilLab : OUTPUT File Unit Number
+ integer noUNIT
+ ! FilNam : OUTPUT File Unit Number (New)
+ integer nwUNIT
+ common / SISVAT_loc_num / nwUNIT
+ integer iwr, itPhys
+ integer ikl, isn, isl, ist, it
+ ! Soil/Water Body Identifier
+ integer ist__s, ist__w
+ ! Seasonal Mask
+ integer growth
+ ! Land+Ice / Open Sea Mask
+ integer LISmsk
+ ! Snow-Ice / No Snow-Ice Mask
+ integer LSnMsk
+ ! Ice / No Ice Mask
+ integer IceMsk, IcIndx(klonv)
+ ! Snow / No Snow Mask
+ integer SnoMsk
+ ! Rain Contribution to the Canopy
+ real drr_Ca, rrCa_n, drip
+ ! Snow Contribution to the Canopy
+ real dsn_Ca, snCa_n, FallOK(klonv)
+ ! Fallen Snow Density (PAHAUT)
+ real roSMin, roSn_1, roSn_2, roSn_3
+ ! Max. Fallen Snow Density
+ real roSMax
+ ! Fallen Snow Dendric.(GIRAUD)
+ real Dendr1, Dendr2, Dendr3
+ ! Fallen Snow Spheric.(GIRAUD)
+ real Spher1, Spher2, Spher3, Spher4
+ ! Polar Snow Switch
+ real Polair
+ real PorSno, Por_BS, Salt_f, PorRef
+#if(sw)
+ real PorVol, rWater
+ real rusNEW, rdzNEW, etaNEW
+#endif
+ real ro_new
+ ! Maximum Polar Temperature
+ real TaPole
+ ! Minimum realistic Temperature
+ real T__Min
+ ! Emissivity of Vegetation
+ real EmiVeg
+ ! Emissivity of Soil
+ real EmiSol
+ ! Emissivity of Snow
+ real EmiSno
+ ! Emissivity of a Water Area
+ real EmiWat
+ ! Square of Von Karman Constant
+ real vk2
+ ! (u*)**2
+ real u2star
+#if(WR)
+ ! Friction Velocity (aer.resist.)
+ real u_star
+#endif
+ ! Fallen Leaves Switch
+ real fallen
+ ! Sea Roughness Length
+ real Z0mSea, Z0hSea
+ ! Land Roughness Length
+ real Z0mLnd
+#if(ZN)
+ ! u*t/u*
+ real sqrrZ0
+#endif
+ ! Marticorena & B. 1995 JGR (20)
+ real f_eff
+ ! Fundamental * Roughness
+ real A_Fact
+ ! Smooth R Snow Roughness Length
+ real Z0m_nu
+ ! BSnow Roughness Length
+ real Z0mBSn
+ ! Mimimum BSnow Roughness Length
+ real Z0mBS0
+ ! Mimimum Snow Roughness Length
+ real Z0m_S0
+ ! Maximum Snow Roughness Length
+ real Z0m_S1
+#if(SZ)
+ ! Regime Snow Roughness Length
+ real Z0Sa_N
+ ! 1.if Rgm Snow Roughness Length
+ real Z0SaSi
+#endif
+#if(GL)
+ ! Mimimum GIMEX Roughness Length
+ real Z0_GIM
+#endif
+ ! Sea-Ice ISW Roughness Length
+ real Z0_ICE
+ ! Snow Surface Roughness Length
+ real Z0m_Sn, Z0m_90
+ ! Snow Layer Switch
+ real SnoWat
+#if(RN)
+ real rstar, alors
+ real rstar0, rstar1, rstar2
+#endif
+ ! 1. => Same Type of Grains
+ real SameOK
+ ! Averaged G1, same Grains
+ real G1same
+ ! Averaged G2, same Grains
+ real G2same
+ ! 1. => Lay1 Type: Dendritic
+ real typ__1
+ ! dz X ro, if fresh Snow
+ real zroNEW
+ ! G1, if fresh Snow
+ real G1_NEW
+ ! G2, if fresh Snow
+ real G2_NEW
+ ! dz X ro, if old Snow
+ real zroOLD
+ ! G1, if old Snow
+ real G1_OLD
+ ! G2, if old Snow
+ real G2_OLD
+ ! Size, if fresh Snow
+ real SizNEW
+ ! Spheric.,if fresh Snow
+ real SphNEW
+ ! Size, if old Snow
+ real SizOLD
+ ! Spheric.,if old Snow
+ real SphOLD
+ ! Averaged Grain Size
+ real Siz_av
+ ! Averaged Grain Spher.
+ real Sph_av
+ ! Averaged Grain Dendr.
+ real Den_av
+ ! 1. => Average is Dendr.
+ real DendOK
+ ! Averaged G1, diff. Grains
+ real G1diff
+ ! Averaged G2, diff. Grains
+ real G2diff
+ ! Averaged G1
+ real G1
+ ! Averaged G2
+ real G2
+ ! Polynomial fit z0=f(T)
+ real param
+ ! Fit Z0_obs=f(T) (m)
+ real Z0_obs
+ ! min T of linear fit (K)
+ real tamin
+ ! max T of linear fit (K)
+ real tamax
+ ! Coefs for z0=f(T)
+ real coefa, coefb, coefc, coefd
+ ! Air temperature thresholds
+ real ta1, ta2, ta3
+ ! z0 thresholds
+ real z01, z02, z03
+ ! Critical param.
+ real tt_c, vv_c
+ ! Temporary variables
+ real tt_tmp, vv_tmp, vv_virt
+ ! .true. if Kotlyakov 1961 else density from obs.
+ logical density_kotlyakov
+#if(BS)
+ ! Correc. factor for drift ratio
+ real Fac
+#endif
+
+ ! +--Energy Budget
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(e1)
+ ! Energy Imbalances Counter
+ integer noEBal
+ common / SISVAT__EBal / noEBal
+ ! Soil+Vegetat Power Forcing
+ real Enrsvd(klonv)
+ ! Soil+Snow , Power Balance
+ real EnsBal
+ ! Vegetat, Power Balance
+ real EnvBal
+#endif
+
+ ! +--Water (Mass) Budget
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(m0)
+ ! Water Imbalances Counter
+ integer noWBal
+ common / SISVAT__WBal / noWBal
+ ! Soil+Vegetat, before Forcing
+ real Watsv0(klonv)
+ ! Soil+Vegetat Water Forcing
+ real Watsvd(klonv)
+ ! Soil+Vegetat, Water Balance
+ real Watbal
+#endif
+
+ ! +--Snow (Mass) Budget
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(m1)
+ ! Water Imbalances Counter
+ integer noSBal
+ common / SISVAT__SBal / noSBal
+ ! Snow Initial/Final Mass
+ real SIWm_0(klonv), SIWm_1(klonv)
+ ! Snow Initial/Final ATM Forcing
+ real SIWa_i(klonv), SIWa_f(klonv)
+ ! Snow Initial/Final BLS Forcing
+ real SIWe_i(klonv), SIWe_f(klonv)
+ ! Snow Pack Mass Balance
+ real SnoBal
+#endif
+
+ ! +--Internal DATA
+ ! + =============
+
+#if(MT)
+ ! SBL Scheme Switch
+ data Garrat/.true./
+#endif
+ ! Minimum realistic Temperature
+ data T__Min/200.00/
+#if(AC)
+ ! Maximum Polar Temperature
+ data TaPole/283.15/
+#endif
+ ! Maximum Polar Temperature
+ data TaPole/268.15/
+#if(EU)
+ ! Minimum Snow Density
+ data roSMin/25./
+#endif
+#if(BS)
+ ! Minimum Snow Density
+ data roSMin/300./
+#endif
+#if(AC)
+ ! Minimum Snow Density
+ data roSMin/300./
+#endif
+ ! Minimum Snow Density
+ data roSMin/300./
+ !XF
+#if(EU)
+ ! Max Fresh Snow Density
+ data roSMax/150./
+#endif
+ ! Max Fresh Snow Density
+ data roSMax/400./
+ ! Critical Temp. (degC)
+ ! tt_c=-2. => rho->quickly to rho(vv_c) when T->-inf
+ data tt_c/-2.0/
+ ! Critical Wind speed (m/s)
+ ! vv_c=14.3 => rho->300 when T->-inf
+ data vv_c/14.3/
+ ! Fall.Sno.Density, Indep. Param.
+ data roSn_1/109./
+ ! Fall.Sno.Density, Temper.Param.
+ data roSn_2/6./
+ ! Fall.Sno.Density, Wind Param.
+ data roSn_3/26./
+ ! Fall.Sno.Dendric.,Wind 1/Param.
+ data Dendr1/17.12/
+ ! Fall.Sno.Dendric.,Wind 2/Param.
+ data Dendr2/128./
+ ! Fall.Sno.Dendric.,Indep. Param.
+ data Dendr3/-20./
+ ! Fall.Sno.Spheric.,Wind 1/Param.
+ data Spher1/7.87/
+ ! Fall.Sno.Spheric.,Wind 2/Param.
+ data Spher2/38./
+ ! Fall.Sno.Spheric.,Wind 3/Param.
+ data Spher3/50./
+ ! Fall.Sno.Spheric.,Indep. Param.
+ data Spher4/90./
+ ! Emissivities : Pielke, 1984, pp. 383,409
+ ! EmisnoAO and EmiWatAO are defined and fixed in MAR_phy.inc !AO_CK 20/02/2020
+ ! Emissivity of Soil
+ data EmiSol/0.94/
+ ! Emissivity of Vegetation
+ data EmiVeg/0.98/
+ ! Emissivity of a Water Area
+ data EmiWat/0.99/
+ ! Emissivity of Snow
+ data EmiSno/0.99/
+
+ ! Fallen Leaves Switch
+ data fallen/0./
+ ! MINimum Snow Roughness Length
+ ! for Momentum if Blowing Snow
+ ! Gallee et al. 2001 BLM 99 (19)
+ data Z0mBS0/0.5e-6/
+ ! MINimum Snow Roughness Length
+ data Z0m_S0/0.00005/
+ ! MINimum Snow Roughness Length
+#if(MG)
+ ! MegaDunes included
+ data Z0m_S0/0.00200/
+#endif
+ ! MAXimum Snow Roughness Length
+ ! (Sastrugis)
+ data Z0m_S1/0.030/
+#if(GL)
+ ! Ice Min Z0 = 0.0013 m (Broeke)
+ ! Old Ice Z0 = 0.0500 m (Bruce)
+ ! 0.0500 m (Smeets)
+ ! 0.1200 m (Broeke)
+ data Z0_GIM/0.0015/
+#endif
+ ! Sea-Ice Z0 = 0.0010 m (Andreas)
+ ! (Ice Station Weddel -- ISW)
+ data Z0_ICE/0.0010/
+ ! Square of Von Karman Constant
+ vk2 = vonkar * vonkar
+#if(FL)
+ ! Fallen Leaves Switch
+ fallen = 1.
+#endif
+
+ ! +..BEGIN.main.
+ ! +--SISVAT Forcing VERIFICATION
+ ! + ===========================
+
+ if(.not. iniOUT) then
+ iniOUT = .true.
+ if(IRs_SV(1) > -epsi) &
+ write(6, 600)
+600 format(/, '### SISVAT ERROR, Soil IR Upward not defined ###', &
+ /, '### Initialize and Store IRs_SV ###')
+
+ ! OUTPUT
+ ! ======
+
+ FilLab = 'SISVAT'
+ SepLab = '_'
+ nwUNIT = 51
+ endif
+#if(E0)
+ do ikl = 1, klonv
+ if(lwriSV(ikl) /= 0 .and. no__SV(lwriSV(ikl)) == 0) then
+ nwUNIT = nwUNIT + 1
+ no__SV(lwriSV(ikl)) = nwUNIT
+ write(FilNam, '(a6,a1,2(i3.3,a1),i1)') &
+ FilLab, SepLab, i___SV(lwriSV(ikl)), &
+ SepLab, j___SV(lwriSV(ikl)), &
+ SepLab, n___SV(lwriSV(ikl))
+ open(unit=nwUNIT, status='unknown', file=FilNam)
+ rewind nwUNIT
+ endif
+ enddo
+ do ikl = 1, klonv
+ if(lwriSV(ikl) /= 0) then
+ noUNIT = no__SV(lwriSV(ikl))
+ write(noUNIT, 5000) daHost, i___SV(lwriSV(ikl)), &
+ j___SV(lwriSV(ikl)), &
+ n___SV(lwriSV(ikl)), &
+ Z0m_SV(ikl), &
+ albisv(ikl)
+5000 format( &
+ /, a18, '| Grid Point ', 2i4, &
+ ' (', i2, ')', &
+ ' | Z0m =', f12.6, ' | Albedo = ', f6.3, ' |', &
+ /, ' -------+', 7('---------+'), 2('--------+'))
+ endif
+ enddo
+#endif
+
+ ! +--"Soil" Humidity of Water Bodies
+ ! + ===============================
+
+ do ikl = 1, klonv
+ ! Soil Type
+ ist = isotSV(ikl)
+ ! 1 => Soil
+ ist__s = min(ist, 1)
+ ! 1 => Water Body
+ ist__w = 1 - ist__s
+ do isl = -nsol, 0
+ ! Soil + Water Body
+ eta_SV(ikl, isl) = eta_SV(ikl, isl) * ist__s &
+ + etadSV(ist) * ist__w
+ enddo
+
+ ! +--Vertical Discretization Factor
+ ! + ==============================
+ ! Soil + Water Body
+ LSdzsv(ikl) = ist__s &
+ + OcndSV * ist__w
+ enddo
+
+ ! +--Vegetation Temperature Limits
+ ! + =============================
+
+ do ikl = 1, klonv
+ TvegSV(ikl) = max(TvegSV(ikl), T__Min) ! T__Min = 200.K
+
+ ! +--LAI Assignation and Fallen Leaves Correction (#FL)
+ ! + ==================================================
+
+ LAI0SV(ikl) = LAI0SV(ikl) * min(1, ivgtSV(ikl)) ! NO LAI if
+ ! + ! no vegetation
+
+ if(ivgtSV(ikl) == 13) then ! city
+ LAI0SV(ikl) = 0.
+ glf0SV(ikl) = 0.
+ endif
+
+ glf_sv(ikl) = glf0SV(ikl)
+#if(FL)
+ glf_sv(ikl) = 1.
+#endif
+ LAI_sv(ikl) = LAI0SV(ikl)
+#if(FL)
+ LAI_sv(ikl) = LAI_sv(ikl) * glf0SV(ikl)
+#endif
+ enddo
+
+ ! +--LAI in Presence of Snow
+ ! + =======================
+ do ikl = 1, klonv
+ z_snsv(ikl) = 0.0
+ enddo
+ do isn = 1, nsno
+ do ikl = 1, klonv
+ z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl, isn)
+ zzsnsv(ikl, isn) = z_snsv(ikl)
+ enddo
+ enddo
+ ! + ASSUMPTION: LAI decreases when Snow Thickness increases,
+ ! + ^^^^^^^^^^ becoming 0 when Snow Thickn. = Displac.Height
+ do ikl = 1, klonv
+ LAI_sv(ikl) = LAI_sv(ikl) &
+ * (1.0 - zzsnsv(ikl, isnoSV(ikl)) &
+ / (DH_dSV(ivgtSV(ikl)) + epsi))
+ LAI_sv(ikl) = max(LAI_sv(ikl), zero)
+ LAI_sv(ikl) = min(LAI_sv(ikl), argmax)
+ enddo
+
+ ! +--Interception of Rain by the Canopy
+ ! + ==================================
+
+ ! Vegetation Forcing
+ ! ------------------
+#if(m0)
+ do ikl = 1, klonv
+ Watsv0(ikl) = rrCaSV(ikl) ! Canopy Water Cont.
+ Watsvd(ikl) = drr_SV(ikl) ! Precipitation
+ enddo
+#endif
+
+ ! +--New Canopy Water Content
+ ! + ------------------------
+
+ do ikl = 1, klonv
+ ! Precip. Max. Intercept.
+ rrMxsv(ikl) = 0.2 * max(epsi, LAI_sv(ikl))
+ ! Canopy Ventilation Coe. (DR97, eqn 3.6)
+ Sigmsv(ikl) = 1.0 - exp(-demi * LAI_sv(ikl))
+ ! Intercepted Rain
+ drr_Ca = drr_SV(ikl) * Sigmsv(ikl) &
+ * dt__SV
+ ! New Canopy Water Contnt (DR97, eqn 3.28)
+ rrCa_n = rrCaSV(ikl) + drr_Ca
+ ! Water Drip
+ drip = rrCa_n - rrMxsv(ikl)
+ drip = max(zero, drip)
+ rrCa_n = rrCa_n - drip
+ ! Update Rain Contribut.
+ drr_SV(ikl) = drr_SV(ikl) + (rrCaSV(ikl) &
+ - rrCa_n) &
+ / dt__SV
+ RuofSV(ikl, 1) = RuofSV(ikl, 1) + max(0., drr_SV(ikl))
+ ! Upd. Canopy Water Content
+ rrCaSV(ikl) = rrCa_n
+
+ ! +--Interception of Snow by the Canopy
+ ! + ==================================
+
+ ! cXF 03/03/2021 not relevant
+ ! ! Intercepted Snow
+ ! dsn_Ca = dsn_SV(ikl) * Sigmsv(ikl) * dt__SV
+ ! ! New Canopy Snow Thickn.
+ ! snCa_n = snCaSV(ikl) + dsn_Ca
+ ! drip = snCa_n - rrMxsv(ikl)
+ ! drip = max(zero, drip)
+ ! snCa_n = snCa_n - drip
+ ! ! Update Snow Contribut.
+ ! dsn_SV(ikl) = dsn_SV(ikl) + (snCaSV(ikl) - snCa_n) / dt__SV
+ ! ! Upd.Canopy Snow Thickn.
+ ! snCaSV(ikl) = snCa_n
+ snCaSV(ikl) = 0.
+ enddo
+
+ ! +--Snow Fall from the Canopy
+ ! + =========================
+
+ ! + ASSUMPTION: snow fall from the canopy,
+ ! + ^^^^^^^^^^ when the temperature of the vegetation is positive
+ ! + (.OR. when snow over the canopy is saturated with water)
+
+ ! do ikl = 1, klonv
+ ! FallOK(ikl) = max(zero, sign(unun, TvegSV(ikl) - TfSnow + epsi))&
+ ! * max(zero, sign(unun, snCaSV(ikl) - epsi))
+ ! dsn_SV(ikl) = dsn_SV(ikl) + snCaSV(ikl) * FallOK(ikl)&
+ ! / dt__SV
+ ! snCaSV(ikl) = snCaSV(ikl) * (1. - FallOK(ikl))
+#if(AE)
+ ! +--Blowing Particles Threshold Friction velocity
+ ! + =============================================
+ ! usthSV(ikl) = 1.0e+2
+#endif
+ ! end do
+
+ ! +--Contribution of Snow to the Surface Snow Pack
+ ! + =============================================
+
+ if(SnoMod) then
+#if(m1)
+ ! Snow Initial Mass (below the Canopy) and Forcing
+ ! ------------------------------------------------
+ do ikl = 1, klonv
+ ! [mm w.e.]
+ SIWa_i(ikl) = (drr_SV(ikl) + dsn_SV(ikl)) * dt__SV
+ SIWe_i(ikl) = dbs_SV(ikl)
+ SIWm_0(ikl) = BufsSV(ikl) + HFraSV(ikl) * ro_Ice
+ do isn = 1, nsno
+ SIWm_0(ikl) = SIWm_0(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ enddo
+ enddo
+#endif
+ ! +--Blowing Snow
+ ! + ------------
+ if(BloMod) then
+ if(klonv == 1) then
+ if(isnoSV(1) >= 2 .and. &
+ TsisSV(1, max(1, isnoSV(1))) < 273. .and. &
+ ro__SV(1, max(1, isnoSV(1))) < 500. .and. &
+ eta_SV(1, max(1, isnoSV(1))) < epsi) then
+ ! + **********
+ call SISVAT_BSn
+ ! + **********
+ endif
+ else
+ ! + **********
+ call SISVAT_BSn
+ ! + **********
+ endif
+ endif
+#if(ve)
+ ! **********
+ call SISVAT_wEq('_BSn ', 1)
+ ! **********
+#endif
+
+ ! +--Sea Ice
+ ! + -------
+
+ ! + **********
+ call SISVAT_SIc(SIvAcr)
+ ! + **********
+#if(ve)
+ ! **********
+ call SISVAT_wEq('_SIc ', 0)
+ ! **********
+#endif
+
+ ! +--Buffer Layer
+ ! + ------------
+ do ikl = 1, klonv
+ ! BufsSV(ikl) [mm w.e.], i.e [kg/m2]
+ d_Bufs = max(dsn_SV(ikl) * dt__SV, 0.)
+ dsn_SV(ikl) = 0.
+ Bufs_N = BufsSV(ikl) + d_Bufs
+#if(s0)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT for Buffer G1, G2 variables
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6601) BufsSV(ikl), d_Bufs, Bufs_N
+6601 format(/, 'Buffer *: ', 3e15.6)
+#endif
+ ! +--Snow Density
+ ! + ^^^^^^^^^^^^
+ Polair = zero
+#if(NP)
+ Polair = max(zero, &
+ sign(unun, TaPole &
+ - TaT_SV(ikl)))
+#endif
+ Polair = max(zero, sign(unun, TaPole - TaT_SV(ikl)))
+ ! Fallen Snow Density [kg/m3] Pahaut (CEN)
+ Buf_ro = max(rosMin, &
+ roSn_1 + roSn_2 * (TaT_SV(ikl) - TfSnow) &
+ + roSn_3 * sqrt(VV10SV(ikl)))
+ ! Fallen Snow Density Kotlyakov (1961)
+#if(NP)
+ BufPro = max(rosMin, &
+ 104.*sqrt(max(VV10SV(ikl) - 6.0, 0.0)))
+#endif
+
+ ! Fallen Snow Density, Adapted for Antarctica
+ density_kotlyakov = .true.
+#if(AC)
+ ! C.Agosta snow densisty as if BS is on b
+ density_kotlyakov = .false.
+#endif
+#if(BS)
+ ! C.Amory BS 2018
+ density_kotlyakov = .false.
+#endif
+ if(density_kotlyakov) then
+ tt_tmp = TaT_SV(ikl) - TfSnow
+ vv_tmp = VV10SV(ikl)
+ ! + ... [ A compromise between
+ ! + ... Kotlyakov (1961) and Lenaerts (2012, JGR, Part1) ]
+ if(tt_tmp >= -10) then
+ BufPro = max(rosMin, &
+ 104.*sqrt(max(vv_tmp - 6.0, 0.0))) ! Kotlyakov (1961)
+ else
+ vv_virt = (tt_c * vv_tmp + vv_c * (tt_tmp + 10)) &
+ / (tt_c + tt_tmp + 10)
+ BufPro = 104.*sqrt(max(vv_virt - 6.0, 0.0))
+ endif
+ else
+ ! + ... [ density derived from observations of the first 50cm of
+ ! + ... snow - cf. Rajashree Datta - and multiplied by 0.8 ]
+ ! + ... C. Agosta, 2016-09
+ !c #SD BufPro = 149.2 + 6.84*VV10SV(ikl) + 0.48*Tsrfsv(ikl)
+ !c #SD BufPro = 125 + 14*VV10SV(ikl) + 0.6*Tsrfsv(ikl) !MAJ CK and CAm
+ BufPro = 200 + 21 * VV10SV(ikl)!CK 29/07/19
+ endif
+ ! Temperate Snow or Polar Snow
+ Bros_N = (1.-Polair) * Buf_ro &
+ + Polair * BufPro
+
+ !XF !!!!
+ Bros_N = max(20., max(rosMin, Bros_N))
+ Bros_N = min(400., min(rosMax - 1, Bros_N)) ! for dz_min in SISVAT_zSn
+ !XF !!!!
+
+#if(BS)
+ ! Density of deposited blown snow
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ Bros_N = frsno
+ ro_new = ro__SV(ikl, max(1, isnoSV(ikl)))
+ ro_new = max(Bros_N, min(roBdSV, ro_new))
+ Fac = 1 - ((ro__SV(ikl, max(1, isnoSV(ikl))) &
+ - roBdSV) / (500.-roBdSV))
+ Fac = max(0., min(1., Fac))
+ dsnbSV(ikl) = Fac * dsnbSV(ikl)
+ Bros_N = Bros_N * (1.0 - dsnbSV(ikl)) &
+ + ro_new * dsnbSV(ikl)
+#endif
+ ! Instantaneous Density if deposited blown Snow (Melted* from Canopy)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ Bros_N = Bros_N * (1.0 - FallOK(ikl)) &
+ + 300.*FallOK(ikl)
+
+ ! Time averaged Density of deposited blown Snow
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ BrosSV(ikl) = (Bros_N * d_Bufs &
+ + BrosSV(ikl) * BufsSV(ikl)) &
+ / max(epsi, Bufs_N)
+#if(s0)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT for Buffer G1, G2 variables
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6602) Buf_ro, Bros_N, BrosSV(ikl), dsnbSV(ikl)
+6602 format('rho *: ', 3e15.6, ' dsnbSV: ', e15.6)
+#endif
+ ! +-- S.Falling Snow Properties (computed as in SISVAT_zAg)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^
+ ! Temperate Snow Dendricity
+ Buf_G1 = max(-G1_dSV, &
+ min(Dendr1 * VV__SV(ikl) - Dendr2, &
+ Dendr3))
+ ! Temperate Snow Sphericity
+ Buf_G2 = min(Spher4, &
+ max(Spher1 * VV__SV(ikl) + Spher2, &
+ Spher3)) !
+ ! Temperate Snow OR Polar Snow
+ Buf_G1 = (1.-Polair) * Buf_G1 &
+ + Polair * G1_dSV
+ Buf_G2 = (1.-Polair) * Buf_G2 &
+ + Polair * ADSdSV
+ ! NO Blown Snow
+ G1 = Buf_G1
+ ! NO Blown Snow
+ G2 = Buf_G2
+#if(s0)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT for Buffer G1, G2 variables
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6603) BG1sSV(ikl), BG2sSV(ikl)
+6603 format('G1,G2 *: ', 3e15.6)
+#endif
+#if(BS)
+ ! S.1. Meme Type de Neige / same Grain Type
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ SameOK = max(zero, &
+ sign(unun, Buf_G1 * G1_dSV &
+ - eps_21))
+ G1same = ((1.0 - dsnbSV(ikl)) * Buf_G1 + dsnbSV(ikl) * G1_dSV)
+ G2same = ((1.0 - dsnbSV(ikl)) * Buf_G2 + dsnbSV(ikl) * ADSdSV)
+ ! Blowing Snow Properties: G1_dSV, ADSdSV
+ ! S.2. Types differents / differents Types
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! =1.=> Dendritic
+ typ__1 = max(zero, sign(unun, epsi - Buf_G1))
+ ! fract.Dendr.Lay.
+ zroNEW = typ__1 * (1.0 - dsnbSV(ikl)) &
+ + (1.-typ__1) * dsnbSV(ikl)
+ ! G1 of Dendr.Lay.
+ G1_NEW = typ__1 * Buf_G1 &
+ + (1.-typ__1) * G1_dSV
+ ! G2 of Dendr.Lay.
+ G2_NEW = typ__1 * Buf_G2 &
+ + (1.-typ__1) * ADSdSV
+ ! fract.Spher.Lay.
+ zroOLD = (1.-typ__1) * (1.0 - dsnbSV(ikl)) &
+ + typ__1 * dsnbSV(ikl)
+ ! G1 of Spher.Lay.
+ G1_OLD = (1.-typ__1) * Buf_G1 &
+ + typ__1 * G1_dSV
+ ! G2 of Spher.Lay.
+ G2_OLD = (1.-typ__1) * Buf_G2 &
+ + typ__1 * ADSdSV
+ ! Size Dendr.Lay.
+ SizNEW = -G1_NEW * DDcdSV / G1_dSV &
+ + (1.+G1_NEW / G1_dSV) &
+ * (G2_NEW * DScdSV / G1_dSV &
+ + (1.-G2_NEW / G1_dSV) * DFcdSV)
+ ! Spher.Dendr.Lay.
+ SphNEW = G2_NEW / G1_dSV
+ ! Size Spher.Lay.
+ SizOLD = G2_OLD
+ ! Spher.Spher.Lay.
+ SphOLD = G1_OLD / G1_dSV
+ ! Averaged Size
+ Siz_av = (zroNEW * SizNEW + zroOLD * SizOLD)
+ ! Averaged Sphericity
+ Sph_av = min(zroNEW * SphNEW + zroOLD * SphOLD &
+ , unun)
+ Den_av = min((Siz_av - (Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV)) &
+ / (DDcdSV - (Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV)) &
+ , unun)
+ ! Small Grains
+ ! Faceted Grains
+ DendOK = max(zero, &
+ sign(unun, Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV &
+ - Siz_av))
+ ! +... REMARQUE: le type moyen (dendritique ou non) depend
+ ! + ^^^^^^^^ de la comparaison avec le diametre optique
+ ! + d'une neige recente de dendricite nulle
+ ! +... REMARK: the mean type (dendritic or not) depends
+ ! + ^^^^^^ on the comparaison with the optical diameter
+ ! + of a recent snow having zero dendricity
+ G1diff = (-DendOK * Den_av &
+ + (1.-DendOK) * Sph_av) * G1_dSV
+ G2diff = DendOK * Sph_av * G1_dSV &
+ + (1.-DendOK) * Siz_av
+ G1 = SameOK * G1same &
+ + (1.-SameOK) * G1diff
+ G2 = SameOK * G2same &
+ + (1.-SameOK) * G2diff
+#endif
+ ! FallOK : Melted * from Canopy
+ BG1__N = ((1.-FallOK(ikl)) * G1 &
+ + FallOK(ikl) * 99.) &
+ * d_Bufs / max(epsi, d_Bufs)
+ ! FallOK : Melted * from Canopy
+ BG2__N = ((1.-FallOK(ikl)) * G2 &
+ + FallOK(ikl) * 30.) &
+ * d_Bufs / max(epsi, d_Bufs)
+
+ ! +-- S.Buffer Snow Properties (computed as in SISVAT_zAg)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^
+ ! Falling Snow
+ Buf_G1 = BG1__N
+ ! Falling Snow
+ Buf_G2 = BG2__N
+#if(s0)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT for Buffer G1, G2 variables
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6604) Buf_G1, Buf_G2, FallOK(ikl) &
+ , TvegSV(ikl)
+6604 format('G1,G2 F*: ', 3e15.6, ' T__Veg: ', e15.6)
+#endif
+ ! S.1. Meme Type de Neige / same Grain Type
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ SameOK = max(zero, &
+ sign(unun, Buf_G1 * BG1sSV(ikl) &
+ - eps_21))
+ G1same = (d_Bufs * Buf_G1 + BufsSV(ikl) * BG1sSV(ikl)) &
+ / max(epsi, Bufs_N)
+ G2same = (d_Bufs * Buf_G2 + BufsSV(ikl) * BG2sSV(ikl)) &
+ / max(epsi, Bufs_N)
+
+ ! S.2. Types differents / differents Types
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ typ__1 = max(zero, sign(unun, epsi - Buf_G1)) ! =1.=> Dendritic
+ ! fract.Dendr.Lay.
+ zroNEW = (typ__1 * d_Bufs &
+ + (1.-typ__1) * BufsSV(ikl)) &
+ / max(epsi, Bufs_N)
+ ! G1 of Dendr.Lay.
+ G1_NEW = typ__1 * Buf_G1 &
+ + (1.-typ__1) * BG1sSV(ikl)
+ ! G2 of Dendr.Lay.
+ G2_NEW = typ__1 * Buf_G2 &
+ + (1.-typ__1) * BG2sSV(ikl)
+ ! fract.Spher.Lay.
+ zroOLD = ((1.-typ__1) * d_Bufs &
+ + typ__1 * BufsSV(ikl)) &
+ / max(epsi, Bufs_N)
+ ! G1 of Spher.Lay.
+ G1_OLD = (1.-typ__1) * Buf_G1 &
+ + typ__1 * BG1sSV(ikl)
+ ! G2 of Spher.Lay.
+ G2_OLD = (1.-typ__1) * Buf_G2 &
+ + typ__1 * BG2sSV(ikl)
+ ! Size Dendr.Lay.
+ SizNEW = -G1_NEW * DDcdSV / G1_dSV &
+ + (1.+G1_NEW / G1_dSV) &
+ * (G2_NEW * DScdSV / G1_dSV &
+ + (1.-G2_NEW / G1_dSV) * DFcdSV)
+ ! Spher.Dendr.Lay.
+ SphNEW = G2_NEW / G1_dSV
+ ! Size Spher.Lay.
+ SizOLD = G2_OLD
+ ! Spher.Spher.Lay.
+ SphOLD = G1_OLD / G1_dSV
+ ! Averaged Size
+ Siz_av = (zroNEW * SizNEW + zroOLD * SizOLD)
+ Sph_av = min(zroNEW * SphNEW + zroOLD * SphOLD &
+ , unun) ! Averaged Sphericity
+ Den_av = min((Siz_av - (Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV)) &
+ / (DDcdSV - (Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV)) &
+ , unun)
+ ! Small Grains
+ ! Faceted Grains
+ DendOK = max(zero, &
+ sign(unun, Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV &
+ - Siz_av))
+ ! +... REMARQUE: le type moyen (dendritique ou non) depend
+ ! + ^^^^^^^^ de la comparaison avec le diametre optique
+ ! + d'une neige recente de dendricite nulle
+ ! +... REMARK: the mean type (dendritic or not) depends
+ ! + ^^^^^^ on the comparaison with the optical diameter
+ ! + of a recent snow having zero dendricity
+
+ G1diff = (-DendOK * Den_av &
+ + (1.-DendOK) * Sph_av) * G1_dSV
+ G2diff = DendOK * Sph_av * G1_dSV &
+ + (1.-DendOK) * Siz_av
+ G1 = SameOK * G1same &
+ + (1.-SameOK) * G1diff
+ G2 = SameOK * G2same &
+ + (1.-SameOK) * G2diff
+
+ BG1sSV(ikl) = G1 &
+ * Bufs_N / max(epsi, Bufs_N)
+ BG2sSV(ikl) = G2 &
+ * Bufs_N / max(epsi, Bufs_N)
+#if(s0)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT for Buffer G1, G2 variables
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6605) Buf_G1, typ__1 &
+ , DendOK, Den_av, Sph_av, Siz_av &
+ , G1same, G1diff, G1
+6605 format('B1,Typ : ', 2e15.6, 11x, 'OK,Den,Sph,Siz: ', 4e15.6 &
+ , /, ' ', 30x, 11x, 'sam,dif,G1 : ', 3e15.6)
+#endif
+ ! +--Update of Buffer Layer Content & Decision about creating a new snow layer
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ BufsSV(ikl) = Bufs_N ! [mm w.e.]
+ ! Allows to create
+ ! a new snow Layer
+ ! if Buffer > SMndSV
+ ! Except if * Erosion dominates
+ NLaysv(ikl) = min(unun, &
+ max(zero, &
+ sign(unun, BufsSV(ikl) &
+ - SMndSV)) &
+ * max(zero, &
+ sign(unun, 0.50 &
+ - dsnbSV(ikl))) &
+ ! Allows to create
+ ! a new snow Layer
+ ! is Buffer > SMndSV*3
+ + max(zero, &
+ sign(unun, BufsSV(ikl) &
+ - SMndSV * 3.00)))
+ ! [mm w.e.] -> [m]
+ Bdzssv(ikl) = 1.e-3 * BufsSV(ikl) * ro_Wat &
+ / max(epsi, BrosSV(ikl))!& [m w.e.] -> [m]
+#if(s0)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT for Buffer G1, G2 variables
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6606) BG1sSV(ikl), BG2sSV(ikl) &
+ , NLaysv(ikl), BdzsSV(ikl)
+6606 format('G1,G2 N*: ', 2e15.6, i15, e27.6)
+#endif
+ enddo
+
+ ! +--Snow Pack Discretization
+ ! + ========================
+ if(klonv == 1) then
+ if(isnoSV(1) >= 1 .or. NLaysv(1) >= 1) then
+ ! + **********
+ call SISVAT_zSn
+ ! + **********
+ endif
+ else
+ ! + **********
+ call SISVAT_zSn
+ ! + **********
+ endif
+#if(ve)
+ ! + **********
+ call SISVAT_wEq('_zSn ', 0)
+ ! + **********
+#endif
+#if(EF)
+ if(isnoSV(1) > 0) &
+ write(6, 6004) isnoSV(1), dsn_SV(1) * dt__SV + BufsSV(1), &
+ ((dzsnSV(1, isn) * ro__SV(1, isn)), isn=1, isnoSV(1))
+6004 format(i3, ' dsn+Buf=', f6.2, 6x, 'z dz *ro =', 10f6.2, &
+ (/, 35x, 10f6.2))
+#endif
+
+ ! +--Add a new Snow Layer
+ ! + ====================
+
+ do ikl = 1, klonv
+#if(EC)
+ if(NLaysv(ikl) > 0) &
+ write(6, 6005) isnoSV(ikl), 1.e3 * Bdzssv(ikl), Brossv(ikl), &
+ BG1ssv(ikl), BG2ssv(ikl)
+6005 format(i3, ' dz = ', f6.3, 3x, ' ro = ', f6.1, 3x, &
+ ' G1 = ', f6.3, 3x, ' G2 = ', f6.1)
+#endif
+ ! +
+ isnoSV(ikl) = isnoSV(ikl) + NLaysv(ikl)
+ isn = isnoSV(ikl)
+ dzsnSV(ikl, isn) = dzsnSV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + Bdzssv(ikl) * NLaysv(ikl)
+ TsisSV(ikl, isn) = TsisSV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + min(TaT_SV(ikl), TfSnow) * NLaysv(ikl)
+ ro__SV(ikl, isn) = ro__SV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + Brossv(ikl) * NLaysv(ikl)
+ eta_SV(ikl, isn) = eta_SV(ikl, isn) * (1 - NLaysv(ikl)) ! + 0.
+ agsnSV(ikl, isn) = agsnSV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + (real(jdarGE + njyrGE(mmarGE)) / 365.+iyrrGE) &
+ * NLaysv(ikl)
+ G1snSV(ikl, isn) = G1snSV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + BG1ssv(ikl) * NLaysv(ikl)
+ G2snSV(ikl, isn) = G2snSV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + BG2ssv(ikl) * NLaysv(ikl)
+ istoSV(ikl, isn) = istoSV(ikl, isn) * (1 - NLaysv(ikl)) &
+ + max(zero, sign(unun, TaT_SV(ikl) &
+ - TfSnow - eps_21)) * istdSV(2) &
+ * NLaysv(ikl)
+ BufsSV(ikl) = BufsSV(ikl) * (1 - NLaysv(ikl))
+ NLaysv(ikl) = 0
+ enddo
+
+ ! +--Snow Pack Thickness
+ ! + -------------------
+
+ do ikl = 1, klonv
+ z_snsv(ikl) = 0.0
+ enddo
+ do isn = 1, nsno
+ do ikl = 1, klonv
+ z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl, isn)
+ zzsnsv(ikl, isn) = z_snsv(ikl)
+ enddo
+ enddo
+
+ ! +--Diffusion of Surficial Water in the Snow Pack
+ ! + ---------------------------------------------
+
+#if(sw)
+ do isn = 1, nsno
+ do ikl = 1, klonv
+ PorVol = 1.-ro__SV(ikl, isn) / ro_Ice
+ PorVol = max(PorVol, zero)
+ rWater = ws0dSV * PorVol * ro_Wat * dzsnSV(ikl, isn) &
+ * max(zero, &
+ sign(unun, rusnSV(ikl) / ro_Wat - zzsnsv(ikl, isn) &
+ + dzsnSV(ikl, isn)))
+ rusNEW = max(rusnSV(ikl) - rWater, zero)
+ rWater = rusnSV(ikl) - rusNEW
+ rdzNEW = rWater &
+ + ro__SV(ikl, isn) * dzsnSV(ikl, isn)
+ etaNEW = rWater / max(epsi, rdzNEW)
+ rusnSV(ikl) = rusNEW
+ ro__SV(ikl, isn) = rdzNEW / max(epsi, dzsnSV(ikl, isn))
+ eta_SV(ikl, isn) = eta_SV(ikl, isn) + etaNEW
+ enddo
+ enddo
+#endif
+
+ endif
+
+#if(EF)
+ if(isnoSV(1) > 0) &
+ write(6, 6006) isnoSV(1), dsn_SV(1) * dt__SV + BufsSV(1), &
+ ((dzsnSV(1, isn) * ro__SV(1, isn)), isn=1, isnoSV(1))
+6006 format(i3, ' dsn+Buf=', f6.2, 6x, '* dz *ro =', 10f6.2, &
+ (/, 35x, 10f6.2))
+#endif
+
+#if(BD)
+ ! +--Blowing Dust
+ ! + ============
+
+ if(BloMod) then
+ ! + ***************
+ call SISVAT_BDu
+ ! + ***************
+ endif
+#endif
+
+ ! +--Soil Albedo: Soil Humidity Correction
+ ! + ==========================================
+
+ ! +... REFERENCE: McCumber and Pielke (1981), Pielke (1984)
+ ! + ^^^^^^^^^
+ do ikl = 1, klonv
+ albssv(ikl) = &
+ alb0SV(ikl) * (1.0 - min(demi, eta_SV(ikl, 0) &
+ / etadSV(isotSV(ikl))))**0.5
+ !XF
+ ! +... REMARK: Albedo of Water Surfaces (isotSV=0):
+ ! + ^^^^^^ alb0SV := 2 X effective value, while
+ ! + eta_SV := etadSV
+ enddo
+
+ ! +--Snow Pack Optical Properties
+ ! + ============================
+
+ if(SnoMod) then
+
+ ! + ******
+ call SnOptP
+ ! + ******
+
+ else
+ do ikl = 1, klonv
+ sEX_sv(ikl, 1) = 1.0
+ sEX_sv(ikl, 0) = 0.0
+ albisv(ikl) = albssv(ikl)
+ enddo
+ endif
+#if(ve)
+ ! + **********
+ call SISVAT_wEq('SnOptP', 0)
+ ! + **********
+#endif
+
+ ! +--Solar Radiation Absorption and Effective Leaf Area Index
+ ! + ========================================================
+
+ ! + ******
+ call VgOptP
+ ! + ******
+
+ ! +--Surface-Canopy Emissivity
+ ! + =========================
+
+ do ikl = 1, klonv
+
+ LSnMsk = min(iun, isnoSV(ikl))
+ ! Veg Transmit.Frac.
+ tau_sv(ikl) = exp(-LAI_sv(ikl))
+ ! Veg+Sno Emissivity
+ Evg_sv(ikl) = EmiVeg * (1 - LSnMsk) + EmiSno * LSnMsk
+ ! Sol+Sno Emissivity
+ Eso_sv(ikl) = EmiSol * (1 - LSnMsk) + EmiSno * LSnMsk
+ emi_SV(ikl) = &
+ (((EmiSol * tau_sv(ikl) &
+ + EmiVeg * (1.0 - tau_sv(ikl))) * LSmask(ikl)) &
+ + EmiWat * (1 - LSmask(ikl))) * (1 - LSnMsk) &
+ + EmiSno * LSnMsk
+
+#if(AO)
+ ! ocean
+ if(LSmask(ikl) == 0) then
+ ! covered by snow/ice
+ if(LSnMSK == 1) then
+ ! Imposed Values from NEMO
+ Evg_sv(ikl) = EmiSnoAO
+ Eso_sv(ikl) = EmiSnoAO
+ Emi_sv(ikl) = EmiSnoAO
+ ! open water
+ else
+ ! Imposed Values from NEMO
+ emi_sv(ikl) = EmiwatAO
+ endif
+ endif
+#endif
+ enddo
+
+ ! +--Soil/Vegetation Forcing/ Upward IR (INPUT, from previous time step)
+ ! + ===================================================================
+
+ do ikl = 1, klonv
+#if(e1)
+ Enrsvd(ikl) = -IRs_SV(ikl)
+#endif
+ IRupsv(ikl) = IRs_SV(ikl) * tau_sv(ikl) ! Upward IR
+ enddo
+
+ ! +--Turbulence
+ ! + ==========
+
+ ! +--Latent Heat of Vaporization/Sublimation
+ ! + ---------------------------------------
+
+ do ikl = 1, klonv
+ SnoWat = min(isnoSV(ikl), 1)
+ Lx_H2O(ikl) = &
+ (1.-SnoWat) * Lv_H2O &
+ + SnoWat * (Ls_H2O * (1.-eta_SV(ikl, isnoSV(ikl))) &
+ + Lv_H2O * eta_SV(ikl, isnoSV(ikl)))
+ enddo
+
+ ! +--Roughness Length for Momentum
+ ! + -----------------------------
+
+ ! +--Land+Sea-Ice / Ice-free Sea Mask
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ IcIndx(ikl) = 0
+ enddo
+ do isn = 1, nsno
+ do ikl = 1, klonv
+ IcIndx(ikl) = max(IcIndx(ikl), &
+ isn * max(0, &
+ sign(1, &
+ int(ro__SV(ikl, isn) - 900.))))
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ LISmsk = min(iiceSV(ikl), 1)
+ LISmsk = max(LSmask(ikl), LISmsk)
+ IceMsk = max(0, sign(1, IcIndx(ikl) - 1))
+ SnoMsk = max(min(isnoSV(ikl) - iiceSV(ikl), 1), 0)
+
+ ! +--Sea Roughness Length
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ Z0mSea = 0.0002
+ Z0hSea = 0.000049
+
+#if(zs)
+ ! Doyle MWR 130 p.3088 2e col
+ Z0mSea = 0.0185 * us__SV(ikl) * us__SV(ikl) * grvinv
+#endif
+ ! Wang MWR 129 p.1377 (21)
+ Z0mSea = 0.016 * us__SV(ikl) * us__SV(ikl) &
+ * grvinv &
+ + 0.11 * akmol &
+ / max(epsi, us__SV(ikl))
+
+#if(zs)
+ ! Wang MWR 129 p.1377 (21) (adapted)
+ Z0mSea = 0.0185 * us__SV(ikl) * us__SV(ikl) &
+ * grvinv &
+ + 0.135 * akmol &
+ / max(epsi, us__SV(ikl))
+#endif
+ ! Wang MWR 129 p.1377 (22)
+ Z0hSea = max(0.000049, &
+ 0.20 * akmol &
+ / max(epsi, us__SV(ikl)))
+
+ Z0mSea = max(Z0mSea, epsi) !
+
+ ! +--Land Roughness Length, Snow Contribution excluded
+ ! + ^^^^^^^^^^^^^^^^^^^^^^ Ice Contribution included
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! +--If vegetation Seasonal Cycle described by LAI :
+ growth = min(max(0, 7 - ivgtSV(ikl)), 1)
+ Z0mLnd = Z0mdSV(ivgtSV(ikl)) * LAI_sv(ikl) * growth &
+ / LAIdSV &
+ + Z0mdSV(ivgtSV(ikl)) * (1 - growth)
+
+ ! +--If vegetation Seasonal Cycle described by GLF only:
+ Z0mLnd = &
+ fallen * Z0mLnd &
+ + (1.-fallen) * Z0mdSV(ivgtSV(ikl)) * glf_sv(ikl) * growth &
+ + Z0mdSV(ivgtSV(ikl)) * (1 - growth)
+
+ ! +--Land Roughness Length, Influence of the Masking by Snow
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Z0mLnd = max(Z0mLnd, &
+ Z0mdSV(0) * (iun - IceMsk) &
+ + Z0_ICE * IceMsk)
+ Z0mLnd = Z0mLnd &
+ - (zzsnsv(ikl, isnoSV(ikl)) &
+ - zzsnsv(ikl, max(IcIndx(ikl), 0))) / 7.
+ Z0mLnd = max(Z0mLnd, 5.e-5) ! Min set := Z0 on *
+ ! +... Roughness disappears under Snow
+ ! + Assumption Height/Roughness Length = 7 is used
+
+ ! +--Z0 Smooth Regime over Snow (Andreas 1995, CRREL Report 95-16, p. 8)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Z0m_nu = 5.e-5 ! z0s~(10-d)*exp(-vonkar/sqrt(1.1e-03))
+
+ ! +--Z0 Saltat.Regime over Snow (Gallee et al., 2001, BLM 99 (19) p.11)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ u2star = us__SV(ikl) * us__SV(ikl)
+ Z0mBSn = u2star * 0.536e-3 - 61.8e-6
+ Z0mBSn = max(Z0mBS0, Z0mBSn)
+
+ ! +--Z0 Smooth + Saltat. Regime
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Z0enSV(ikl) = Z0m_nu &
+ + Z0mBSn
+
+ ! +--Rough Snow Surface Roughness Length (Typical Value)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+#if(tz)
+ Z0m_Sn = 0.250e-3 ! Andreas 1995, CRREL Report 95-16, fig.1&p.2
+#endif
+ ! ! z0r~(10-d)*exp(-vonkar/sqrt(1.5e-03))-5.e-5
+ Z0m_Sn = 2.000e-3 ! Calibration of MAR
+#if(TZ)
+ Z0m_Sn = 1.000e-3 ! Exemple Tuning in RACMO
+ Z0m_Sn = 0.500e-3 ! Exemple Tuning in MAR
+#endif
+
+ ! +--Rough Snow Surface Roughness Length (Variable Sastrugi Height)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ A_Fact = 1.0000 ! Andreas et al., 2004, p.4
+ ! ! ams.confex.com/ams/pdfpapers/68601.pdf
+
+ ! Parameterization of z0 dependance on Temperature (C. Amory, 2017)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! Z0=f(T) deduced from observations, Adelie Land, dec2012-dec2013
+ 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
+ if(TaT_SV(ikl) < ta1) then
+ Z0_obs = z01
+ else if(TaT_SV(ikl) >= ta1 .and. TaT_SV(ikl) < ta2) then
+ Z0_obs = exp(coefa * TaT_SV(ikl) + coefb)
+ else if(TaT_SV(ikl) >= ta2 .and. TaT_SV(ikl) < ta3) then
+ ! ! if st > 0, melting induce smooth surface
+ Z0_obs = exp(coefc * TaT_SV(ikl) + coefd)
+ else
+ Z0_obs = z03
+ endif
+
+ ! Z0_obs = 1.000e-3
+
+ !cCA Snow roughness lenght deduced from observations
+ !cCA (parametrization if no Blowing Snow)
+ !cCA ----------------------------------- C. Agosta 09-2016 -----
+ !cCA Substract Z0enSV(ikl) because re-added later in Z0mnSV(ikl)
+ Z0m_Sn = Z0_obs - Z0enSV(ikl)
+ !cCA -----------------------------------------------------------
+
+ param = Z0_obs / 1. ! param(s) | 1.(m/s)=TUNING
+#if(SZ)
+ ! 0.0001 = TUNING
+ Z0Sa_N = (us__SV(ikl) - 0.2) * param &
+ * max(zero, sign(unun, TfSnow - eps9 &
+ - TsisSV(ikl, isnoSV(ikl))))
+ ! 1 if erosion
+ ! Z0SaSi = max(zero,sign(unun,Z0Sa_N ))
+ Z0SaSi = max(zero, sign(unun, zero - eps9 - uss_SV(ikl)))!
+ Z0Sa_N = max(zero, Z0Sa_N)
+ Z0SaSV(ikl) = &
+ max(Z0SaSV(ikl), Z0SaSV(ikl) &
+ + Z0SaSi * (Z0Sa_N - Z0SaSV(ikl)) * exp(-dt__SV / 43200.)) &
+ - min(dz0_SV(ikl), Z0SaSV(ikl))
+ ! CAUTION: The influence of the sastrugi direction is not yet included
+ ! A=5 if h~10cm
+ A_Fact = Z0SaSV(ikl) * 5.0 / 0.15
+ Z0m_Sn = Z0SaSV(ikl) &
+ - Z0m_nu
+#endif
+#if(ZN)
+ ! +--Z0 Saltat.Regime over Snow (Shao & Lin, 1999, BLM 91 (46) p.222)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ sqrrZ0 = usthSV(ikl) / max(us__SV(ikl), 0.001)
+ sqrrZ0 = min(sqrrZ0, 0.999)
+ Z0mBSn = 0.55 * 0.55 * exp(-sqrrZ0 * sqrrZ0) &
+ * us__SV(ikl) * us__SV(ikl) * grvinv * 0.5
+ ! +--Z0 Smooth + Saltat. Regime (Shao & Lin, 1999, BLM 91 (46) p.222)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Z0enSV(ikl) = (Z0m_nu**sqrrZ0) &
+ * (Z0mBSn**(1.-sqrrZ0))
+ Z0enSV(ikl) = max(Z0enSV(ikl), Z0m_nu)
+#endif
+#if(ZA)
+ ! +--Z0 Smooth Regime over Snow (Andreas etAl., 2004
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ ams.confex.com/ams/pdfpapers/68601.pdf)
+ Z0m_nu = 0.135 * akmol / max(us__SV(ikl), epsi)
+ ! +--Z0 Saltat.Regime over Snow (Andreas etAl., 2004
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^ ams.confex.com/ams/pdfpapers/68601.pdf)
+ Z0mBSn = 0.035 * u2star * grvinv
+ ! +--Z0 Smooth + Saltat. Regime (Andreas etAl., 2004
+ ! ( used by Erosion) ams.confex.com/ams/pdfpapers/68601.pdf)
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Z0enSV(ikl) = Z0m_nu &
+ + Z0mBSn
+ ! +--Z0 Rough Regime over Snow (Andreas etAl., 2004
+ ! + (.not. used by Erosion) ams.confex.com/ams/pdfpapers/68601.pdf)
+ ! ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ u2star = (us__SV(ikl) - 0.1800) / 0.1
+ Z0m_Sn = A_Fact * Z0mBSn * exp(-u2star * u2star)
+ Z0m_90 = (10.-0.025 * VVs_SV(ikl) / 5.) &
+ * exp(-0.4 / sqrt(.00275 + .00001 * max(0., VVs_SV(ikl) - 5.)))
+ Z0m_Sn = DDs_SV(ikl) * Z0m_90 / 45. &
+ -DDs_SV(ikl) * DDs_SV(ikl) * Z0m_90 / (90.*90.)
+#endif
+ ! +--Z0 (Erosion) over Snow (instantaneous or time average)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Z0e_SV(ikl) = Z0enSV(ikl)
+ Z0e_SV(ikl) = Z0emSV(ikl)
+
+ ! +--Momentum Roughness Length
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! Contribution of
+ ! Vegetation Form
+ ! Sastrugi Form
+ ! Snow Erosion
+ Z0mnSV(ikl) = Z0mLnd &
+ + (Z0m_Sn &
+ + Z0enSV(ikl)) * SnoMsk
+
+ ! +--Mom. Roughness Length, Discrimination among Ice/Land and Ice-Free Ocean
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! Ice and Land + Ice-Free Ocean
+ Z0mnSV(ikl) = Z0mnSV(ikl) * LISmsk &
+ + Z0mSea * (1 - LISmsk)
+#if(OR)
+ ! Subgrid Topogr.
+ Z0mnSV(ikl) = Z0mnSV(ikl) + Z0roSV(ikl)
+#endif
+
+#if(GL)
+ ! +--GIS Roughness Length
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ Z0mnSV(ikl) = &
+ (1 - LSmask(ikl)) * Z0mnSV(ikl) &
+ + LSmask(ikl) * max(Z0mnSV(ikl), max(Z0_GIM, &
+ Z0_GIM + (Z0_GIM * 10 - Z0_GIM) * (ro__SV(ikl, isnoSV(ikl)) - 600.) &
+ / (ro_ice - 600.)))
+#endif
+
+ ! +--Mom. Roughness Length, Instantaneous OR Box Moving Average in Time
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! Z0mnSV instant.
+ Z0m_SV(ikl) = Z0mnSV(ikl)
+ ! Z0mnSV Average
+ Z0m_SV(ikl) = Z0mmSV(ikl)
+
+ ! +--Corrected Threshold Friction Velocity before Erosion ! Marticorena and
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! Bergametti 1995
+#if(BS)
+ ! not used anymore since Marticorena and Bergametti disabled !CK 18/07/2018
+ ! Z0e_SV(ikl) = min(Z0m_SV(ikl),Z0e_SV(ikl))
+#endif
+#if(MB)
+ ! f_eff= log(0.35*(0.1 /Z0e_SV(ikl))**0.8) ! JGR 100
+ ! (20) p. 16420 p.16426 2nd ?
+ ! f_eff=1.-(log( Z0m_SV(ikl)/Z0e_SV(ikl) )) &
+ ! /(max( f_eff ,epsi ))
+ ! CONTROL
+ ! f_eff= max( f_eff ,epsi )
+ ! TUNING
+ ! f_eff=1.0 -(1.0 - f_eff) /5.00
+ ! f_eff= min( f_eff ,1.00 )
+ ! usthSV(ikl) = usthSV(ikl)/f_eff
+#endif
+
+ ! +--Roughness Length for Scalars
+ ! + ----------------------------
+ Z0hnSV(ikl) = Z0mnSV(ikl) / 7.4
+ ! (Taylor & Clark, QJRMS 127,p864)
+ ! Z0h = Z0m /100.0 over the Sahel
+#if(SH)
+ Z0hnSV(ikl) = Z0mnSV(ikl) / 100.0
+#endif
+#if(RN)
+ !XF #RN does not work over bare ice
+ !XF MAR is then too warm and not enough melt
+ rstar = Z0mnSV(ikl) * us__SV(ikl) / akmol
+ rstar = max(epsi, min(rstar, thous))
+ alors = log(rstar)
+ rstar0 = 1.250e0 * max(zero, sign(unun, 0.135e0 - rstar)) &
+ + (1.-max(zero, sign(unun, 0.135e0 - rstar))) &
+ * (0.149e0 * max(zero, sign(unun, 2.500e0 - rstar)) &
+ + 0.317e0 &
+ * (1.-max(zero, sign(unun, 2.500e0 - rstar))))
+ rstar1 = 0.*max(zero, sign(unun, 0.135e0 - rstar)) &
+ + (1.-max(zero, sign(unun, 0.135e0 - rstar))) &
+ * (-0.55e0 * max(zero, sign(unun, 2.500e0 - rstar)) &
+ - 0.565 &
+ * (1.-max(zero, sign(unun, 2.500e0 - rstar))))
+ rstar2 = 0.*max(zero, sign(unun, 0.135e0 - rstar)) &
+ + (1.-max(zero, sign(unun, 0.135e0 - rstar))) &
+ * (0.*max(zero, sign(unun, 2.500e0 - rstar)) &
+ - 0.183 &
+ * (unun - max(zero, sign(unun, 2.500e0 - rstar))))
+ if(ro__SV(ikl, isnoSV(ikl)) > 50 &
+ .and. ro__SV(ikl, isnoSV(ikl)) < roSdSV) then
+ Z0hnSV(ikl) = max(zero &
+ , sign(unun, zzsnsv(ikl, isnoSV(ikl)) - epsi)) &
+ * exp(rstar0 + rstar1 * alors + rstar2 * alors * alors) &
+ * 0.001e0 + Z0hnSV(ikl) * (1.-max(zero &
+ , sign(unun, zzsnsv(ikl, isnoSV(ikl)) - epsi)))
+ endif
+#endif
+
+ ! Ice-free Ocean + Ice and Land
+ Z0hnSV(ikl) = Z0hSea * (1 - LISmsk) &
+ + Z0hnSV(ikl) * LISmsk
+
+ Z0h_SV(ikl) = Z0hnSV(ikl)
+ Z0h_SV(ikl) = Z0hmSV(ikl)
+
+ ! +--Contributions of the Roughness Lenghths to the neutral Drag Coefficient
+ ! + -----------------------------------------------------------------------
+
+#if(MT)
+ ! Min Z0_m (Garrat Scheme)
+ Z0m_SV(ikl) = max(2.0e-6, Z0m_SV(ikl))
+#endif
+ Z0m_SV(ikl) = min(Z0m_SV(ikl), za__SV(ikl) * 0.3333)
+ sqrCm0(ikl) = log(za__SV(ikl) / Z0m_SV(ikl))
+ sqrCh0(ikl) = log(za__SV(ikl) / Z0h_SV(ikl))
+
+#if(wz)
+ if(ikl == 1) write(6, 6661) dsn_SV(ikl), us__SV(ikl), Z0SaSi &
+ , Z0Sa_N, Z0SaSV(ikl), Z0m_Sn, Z0m_SV(ikl)
+6661 format(7f9.6)
+#endif
+
+#if(sz)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! OUTPUT of Roughness Length and Drag Coefficients
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6600) za__SV(ikl), Z0m_SV(ikl) &
+ , sqrCm0(ikl), za__SV(ikl) / Z0m_SV(ikl) &
+ , Z0SaSV(ikl), Z0h_SV(ikl) &
+ , sqrCh0(ikl), za__SV(ikl) / Z0h_SV(ikl)
+6600 format(/, ' ** SISVAT *0 ' &
+ , ' za__SV = ', e12.4, ' Z0m_SV = ', e12.4 &
+ , ' sqrCm0 = ', e12.4, ' Za/Z0m = ', e12.4 &
+ , /, ' ' &
+ , ' Z0SaSV = ', e12.4, ' Z0h_SV = ', e12.4 &
+ , ' sqrCh0 = ', e12.4, ' Za/Z0h = ', e12.4)
+#endif
+
+ ! +--Vertical Stability Correction
+ ! + -----------------------------
+
+ ! +--Surface/Canopy Temperature
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Tsrfsv(ikl) = Sigmsv(ikl) * TvegSV(ikl) &
+ + (1.-Sigmsv(ikl)) * TsisSV(ikl, isnoSV(ikl))
+ enddo
+
+ ! +--Aerodynamic Resistance
+ ! + ^^^^^^^^^^^^^^^^^^^^^^
+#if(CP)
+ if(SnoMod .and. ColPrt) then
+#endif
+
+#if(CP)
+ ! + **********
+ call ColPrt_SBL
+ ! + **********
+#endif
+
+#if(CP)
+ else
+#endif
+
+#if(MT)
+ if(Garrat) then
+ ! + **********
+ call SISVAT_SBL
+ ! + **********
+ else
+#endif
+
+ ! + **********
+ call SISVATeSBL
+ ! + **********
+
+#if(MT)
+ endif
+#endif
+#if(CP)
+ endif
+#endif
+
+ ! +--Friction Velocity
+ ! + -----------------
+
+#if(US)
+ do ikl = 1, klonv
+#if(WR)
+#endif
+ u_star = sqrt(VV__SV(ikl) / ram_sv(ikl))
+ write(6, *) u_star, us__SV(ikl)
+#endif
+#if(US)
+ us__SV(ikl) = sqrt(VV__SV(ikl) / ram_sv(ikl))
+ enddo
+#endif
+
+ ! Canopy Energy Balance
+ ! =====================
+
+ ! + **********
+ call SISVAT_TVg(ETVg_d)
+ ! + **********
+
+ ! +--Surface/Canopy Temperature
+ ! + ==========================
+
+ do ikl = 1, klonv
+ Tsrfsv(ikl) = Sigmsv(ikl) * TvegSV(ikl) &
+ + (1.-Sigmsv(ikl)) * TsisSV(ikl, isnoSV(ikl))
+ enddo
+
+ ! Soil Energy Balance
+ ! ===================
+ do ikl = 1, klonv
+ ist = ntPhys
+ if(isnoSV(ikl) >= 1 .and. TaT_SV(ikl) >= 273.15) ist = ntPhys + 1 ! melting snow
+ if(isnoSV(ikl) <= 0 .and. isotSV(ikl) <= 0) ist = 1 ! sea
+ enddo
+ dt__SV2 = dt__SV
+ dt__SV = dt__SV / real(ist)
+ do it = 1, max(1, ist)
+ ! + **********
+ call SISVAT_TSo(ETSo_0, ETSo_1, ETSo_d)
+ ! + **********
+ enddo
+ dt__SV = dt__SV2
+
+#if(ve)
+ ! + **********
+ call SISVAT_wEq('_TSo ', 0)
+ ! + **********
+#endif
+
+ ! +--Canopy Water Balance
+ ! + =====================
+
+ ! +--Soil Water Potential
+ ! + ------------------------
+
+ do isl = -nsol, 0
+ do ikl = 1, klonv
+ ! Soil Type
+ ist = isotSV(ikl)
+ ! DR97, Eqn.(3.34)
+ psi_sv(ikl, isl) = psidSV(ist) &
+ * (etadSV(ist) / max(epsi, eta_SV(ikl, isl))) &
+ **bCHdSV(ist)
+
+ ! +--Soil Hydraulic Conductivity
+ ! + ---------------------------
+ ! DR97, Eqn.(3.35)
+ Khydsv(ikl, isl) = s2__SV(ist) &
+ * (eta_SV(ikl, isl)**(2.*bCHdSV(ist) + 3.))
+ enddo
+ enddo
+
+ ! + **********
+ call SISVAT_qVg
+ ! + **********
+
+ ! Vegetation Forcing
+ ! ------------------
+#if(m0)
+ do ikl = 1, klonv
+ ! Canopy Precip. IN
+ ! Canopy Precip. OUT
+ ! Canopy Water Evap.
+ Watsvd(ikl) = (Watsvd(ikl) &
+ - drr_SV(ikl) &
+ - Evp_sv(ikl)) * dt__SV
+ enddo
+#endif
+
+ ! +--Melting / Refreezing in the Snow Pack
+ ! + =====================================
+
+ if(SnoMod) then
+
+ ! + **********
+ call SISVAT_qSn()
+ ! + **********
+
+#if(ve)
+ ! + **********
+ call SISVAT_wEq('_qSn ', 0)
+ ! + **********
+#endif
+
+#if(EF)
+ if(isnoSV(1) > 0) &
+ write(6, 6007) isnoSV(1), dsn_SV(1) * dt__SV + BufsSV(1), &
+ ((dzsnSV(1, isn) * ro__SV(1, isn)), isn=1, isnoSV(1))
+6007 format(i3, ' dsn+Buf=', f6.2, 6x, 'q dz *ro =', 10f6.2, &
+ (/, 35x, 10f6.2))
+#endif
+
+ ! +--Snow Pack Thickness
+ ! + -------------------
+ do ikl = 1, klonv
+ z_snsv(ikl) = 0.0
+ enddo
+ do isn = 1, nsno
+ do ikl = 1, klonv
+ z_snsv(ikl) = z_snsv(ikl) + dzsnSV(ikl, isn)
+ zzsnsv(ikl, isn) = z_snsv(ikl)
+ enddo
+ enddo
+
+ ! +--Energy in Excess is added to the first Soil Layer
+ ! + -------------------------------------------------
+ do ikl = 1, klonv
+ z_snsv(ikl) = max(zero, &
+ sign(unun, epsi - z_snsv(ikl)))
+ TsisSV(ikl, 0) = TsisSV(ikl, 0) + EExcsv(ikl) &
+ / (rocsSV(isotSV(ikl)) &
+ + rcwdSV * eta_SV(ikl, 0))
+ EExcsv(ikl) = 0.
+ enddo
+
+#if(m1)
+ ! Snow Final Mass (below the Canopy) and Forcing
+ ! ------------------------------------------------
+ do ikl = 1, klonv
+ ! [mm w.e.]
+ SIWa_f(ikl) = (drr_SV(ikl) + dsn_SV(ikl)) * dt__SV
+ SIWe_f(ikl) = dbs_SV(ikl)
+ SIWm_1(ikl) = BufsSV(ikl) + HFraSV(ikl) * ro_Ice
+ do isn = 1, nsno
+ SIWm_1(ikl) = SIWm_1(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ enddo
+ enddo
+#endif
+ endif
+
+ ! Soil Water Balance
+ ! =====================
+
+ ! + **********
+ call SISVAT_qSo(Wats_0, Wats_1, Wats_d)
+ ! + **********
+
+ ! +--Surface/Canopy Fluxes
+ ! + =====================
+
+ do ikl = 1, klonv
+ ! Downward IR
+ IRdwsv(ikl) = tau_sv(ikl) * IRd_SV(ikl) * Eso_sv(ikl) &
+ + (1.0 - tau_sv(ikl)) * IRd_SV(ikl) * Evg_sv(ikl)
+ ! Upward IR
+ IRupsv(ikl) = IRupsv(ikl) &
+ + 0.5 * IRv_sv(ikl) * (1.-tau_sv(ikl))
+ ! Upward IR
+ ! (effective)
+ ! (positive)
+ IRu_SV(ikl) = -IRupsv(ikl) &
+ + IRd_SV(ikl) &
+ - IRdwsv(ikl)
+ ! Brightness Temperature
+ TBr_sv(ikl) = sqrt(sqrt(IRu_SV(ikl) / stefan))
+ ! u*T*
+ uts_SV(ikl) = (HSv_sv(ikl) + HSs_sv(ikl)) / (rhT_SV(ikl) * Cp)
+ ! u*q*
+ uqs_SV(ikl) = (HLv_sv(ikl) + HLs_sv(ikl)) / (rhT_SV(ikl) * Lv_H2O)
+
+ ! +--Surface/Canopy Temperature
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Tsrfsv(ikl) = Sigmsv(ikl) * TvegSV(ikl) + (1.-Sigmsv(ikl)) * TsisSV(ikl, isnoSV(ikl))
+ enddo
+
+ ! +--Snow Pack Properties (sphericity, dendricity, size)
+ ! + ===================================================
+
+ if(SnoMod) then
+ if(klonv == 1) then
+ if(isnoSV(1) >= 1 .and. itphys == 1) then
+ ! + **********
+ call SISVAT_GSn
+ ! + **********
+ endif
+ else
+ ! + **********
+ call SISVAT_GSn
+ ! + **********
+ endif
+
+#if(ve)
+ ! + **********
+ call SISVAT_wEq('_GSn ', 0)
+ ! + **********
+#endif
+
+ ! +--Surficial Water Freezing, including that of a Water Surface (isotSV=0)
+ ! + ======================================================================
+
+ endif
+
+ ! +--OUTPUT
+ ! + ======
+
+#if(E0)
+ do ikl = 1, klonv
+ if(lwriSV(ikl) /= 0) then
+ noUNIT = no__SV(lwriSV(ikl))
+ write(noUNIT, 5001) &
+ (SoSosv(ikl) + SoCasv(ikl)) * sol_SV(ikl), &
+ IRdwsv(ikl), IRu_SV(ikl), &
+ HSv_sv(ikl) + HSs_sv(ikl), &
+ HLv_sv(ikl) + HLs_sv(ikl), TaT_SV(ikl), &
+ dsn_SV(ikl) * 3.6e3, drr_SV(ikl) * 3.6e3, &
+ SoSosv(ikl) * sol_SV(ikl), &
+ IRv_sv(ikl) * 0.5, &
+ HSv_sv(ikl), HLv_sv(ikl), TvegSV(ikl), &
+ SoCasv(ikl) * sol_SV(ikl), &
+ HSs_sv(ikl), HLs_sv(ikl), TsisSV(ikl, isnoSV(ikl))
+5001 format( &
+ ' |Net Solar| IR Down | IR Up | HS/Dwn=+|', &
+ ' HL/Dwn=+| Temper. | | Snow | Rain |', &
+ /, ' | [W/m2] | [W/m2] | [W/m2] | [W/m2] |', &
+ ' [W/m2] | [K] | | [mm/h] | [mm/h] |', &
+ /, ' -------+', 7('---------+'), 2('--------+'), &
+ /, ' SISVAT |', f8.1, ' |', f8.1, ' |', f8.1, ' |', f8.1, ' |', &
+ f8.1, ' |A', f7.2, ' |', 8x, ' |', 2(f7.2, ' |'), &
+ /, ' Canopy |', f8.1, ' |', 8x, ' |', f8.1, ' |', f8.1, ' |', &
+ f8.1, ' |', f8.2, ' |', 8x, ' |', 2(7x, ' |') &
+ /, ' Soil |', f8.1, ' |', 8x, ' |', 8x, ' |', f8.1, ' |', &
+ f8.1, ' |', f8.2, ' |', 8x, ' |', 2(7x, ' |'))
+#endif
+
+#if(e1)
+ ! +--Energy Budget
+ ! + -------------
+ ! Up Surf. IR
+ Enrsvd(ikl) = Enrsvd(ikl) &
+ ! Offset
+ + IRs_SV(ikl) &
+ ! Net Solar
+ + ((SoSosv(ikl) &
+ + SoCasv(ikl)) * sol_SV(ikl) &
+ ! Downward IR
+ + IRdwsv(ikl) &
+ ! Upward IR
+ + IRupsv(ikl) &
+ ! Sensible
+ + HSv_sv(ikl) + HSs_sv(ikl) &
+ ! Latent
+ + HLv_sv(ikl) + HLs_sv(ikl))
+ write(noUNIT, 5002) Enrsvd(ikl), &
+ ETSo_0(ikl), ETSo_d(ikl), &
+ ETSo_0(ikl) + ETSo_d(ikl), ETSo_1(ikl), &
+ EqSn_0(ikl) / dt__SV, &
+ EqSn_d(ikl) / dt__SV, &
+ (EqSn_1(ikl) - EqSn_0(ikl) - EqSn_d(ikl)) / dt__SV, &
+ EqSn_1(ikl) / dt__SV
+5002 format( &
+ ' -----------------+-------------------+', &
+ '-----------------+-+-----------------+', &
+ '-------------------+', &
+ /, ' SOIL/SNOW/VEGET. | |', &
+ ' Power, Forcing | |', &
+ ' |', &
+ /, ' |', 11x, ' |', &
+ f9.2, ' [W/m2] |', 11x, ' |', &
+ 11x, ' |', &
+ /, ' -----------------+-------------------+', &
+ '-----------------+-------------------+', &
+ '-------------------+', &
+ ! ETSo_0
+ /, ' SOIL/SNOW (TSo) | Energy/dt, Time 0 |', &
+ ! ETSo_d/ETSo_0+d
+ ' Power, Forcing | Sum Tim.0+Forc. |', &
+ ! ETSo_1
+ ' Energy/dt, Time 1 |', &
+ ! ETSo_0
+ /, ' |', f11.2, ' [W/m2] |', &
+ ! ETSo_d/ETSo_0+d
+ f9.2, ' [W/m2] |', f11.2, ' [W/m2] |', &
+ ! ETSo_1
+ f11.2, ' [W/m2] |', &
+ /, ' -----------------+-------------------+', &
+ '-----------------+-------------------+', &
+ '-------------------+', &
+ ! EqSn_0/dt
+ /, ' SNOW (qSn) | Energy/dt, Time 0 |', &
+ ! EqSn_d/dt, 1-0-d
+ ' Power, Excess | D(Tim.1-0-Forc.)|', &
+ ! EqSn_1/dt
+ ' Energy/dt, Time 1 |', &
+ ! EqSn_0/dt
+ /, ' |', f12.2, '[W/m2] |', &
+ ! EqSn_d/dt, 1-0-d
+ f9.2, ' [W/m2] |', f11.2, ' [W/m2] |', &
+ ! EqSn_1/dt
+ f12.2, '[W/m2] | ', &
+ /, ' -----------------+-------------------+', &
+ '-----------------+-------------------+', &
+ '-------------------+')
+
+ EnsBal = ETSo_1(ikl) - (ETSo_0(ikl) + Enrsvd(ikl))
+ EnvBal = Enrsvd(ikl) - ETVg_d(ikl)
+
+#if(e2)
+ if((abs(EnsBal) > 5.e-1) .OR. (lwriSV(ikl) == 2)) then
+#else
+ if(abs(EnsBal) .gt. 5.e-1) then
+#endif
+ write(6, 6001) daHost, i___SV(lwriSV(ikl)), &
+ j___SV(lwriSV(ikl)), &
+ n___SV(lwriSV(ikl)), &
+ ETSo_1(ikl), ETSo_0(ikl), ETSo_d(ikl), &
+ ETSo_1(ikl) - ETSo_0(ikl) - ETSo_d(ikl), &
+ Enrsvd(ikl), ETVg_d(ikl), ETSo_d(ikl), &
+ Enrsvd(ikl) - ETVg_d(ikl) - ETSo_d(ikl)
+6001 format(a18, 3i4, ' (EB1', f15.6, &
+ ') - [(EB0 ', f15.6, ')', &
+ /, 55x, '+(ATM->Snow/Soil', f15.6, ')] ', &
+ '= EBAL', f15.6, ' [W/m2]', &
+ /, 55x, ' (ATM->SISVAT', f18.6, &
+ /, 55x, '- Veg. ImBal.', f18.6, ') ', &
+ /, 55x, '- ATM->SnoSol', f18.6, ') ', &
+ '= ????', f15.6, ' [W/m2]')
+ noEBal = noEBal + 1
+#if(e2)
+ noEBal = noEBal - 1
+#endif
+ if(noEBal >= 10) stop 'TOO MUCH ENERGY IMBALANCES'
+ endif
+#endif
+
+ ! +--Snow Budget [mm w.e.]
+ ! + -----------------------
+#if(m1)
+ write(noUNIT, 5010) &
+ SIWm_0(ikl), SIWa_i(ikl) - SIWa_f(ikl) &
+ , SIWm_0(ikl) + SIWa_i(ikl) - SIWa_f(ikl) &
+ + SIWe_i(ikl) - SIWe_f(ikl) &
+ + SIsubl(ikl) &
+ - SImelt(ikl) &
+ - SIrnof(ikl) &
+ + SIvAcr(ikl) &
+ , SIWm_1(ikl), SIWe_i(ikl) - SIWe_f(ikl) &
+ , SIsubl(ikl) &
+ , -SImelt(ikl) &
+ , -SIrnof(ikl) &
+ , SIvAcr(ikl)
+5010 format(' SNOW | Snow, Time 0 |', &
+ ' Snow, Forcing | Sum |', &
+ ' Snow, Time 1 |', &
+ /, ' |', f13.3, ' [mm] |', &
+ ' A', f9.3, ' [mm] |', f13.3, ' [mm] |', &
+ f13.3, ' [mm] |', &
+ /, ' |', 13x, ' |', &
+ ' E', f9.3, ' [mm] |', 13x, ' |', &
+ 13x, ' |', &
+ /, ' |', 13x, ' |', &
+ ' S', f9.3, ' [mm] |', 13x, ' |', &
+ 13x, ' |', &
+ /, ' |', 13x, ' |', &
+ '(M', f9.3, ' [mm])| (included in A) |', &
+ 13x, ' |', &
+ /, ' |', 13x, ' |', &
+ ' R', f9.3, ' [mm] |', 13x, ' |', &
+ 13x, ' |', &
+ /, ' -----------------+-------------------+', &
+ '-----------------+-------------------+', &
+ '-------------------+')
+ SnoBal = SIWm_1(ikl) - (SIWm_0(ikl) &
+ + SIWa_i(ikl) - SIWa_f(ikl) &
+ + SIWe_i(ikl) - SIWe_f(ikl)) &
+ - SIsubl(ikl) &
+ + SIrnof(ikl)
+
+ SnoBal = SnoBal - SIvAcr(ikl)
+ if(abs(SnoBal) > epsi) then
+ write(6, 6010) daHost, i___SV(lwriSV(ikl)), &
+ j___SV(lwriSV(ikl)), &
+ n___SV(lwriSV(ikl)), &
+ SIWm_1(ikl), SIWm_0(ikl), &
+ SIWa_i(ikl), SIWa_f(ikl), &
+ SIWe_i(ikl), SIWe_f(ikl), &
+ SIsubl(ikl), SImelt(ikl), &
+ SIrnof(ikl), SIvAcr(ikl), &
+ SnoBal
+6010 format(a18, 3i4, ' (MB1', f12.6, &
+ ') - [(MB0 ', f12.6, 15x, ')', &
+ /, 51x, '+(ATM Forcing', f12.6, ' - ', f12.6, ')', &
+ /, 51x, '+(BLS Forcing', f12.6, ' - ', f12.6, ')', &
+ /, 51x, '-(Depo/Sublim', f12.6, 15x, ')', &
+ /, 51x, ' !Melting ', f12.6, ' included in A!', &
+ /, 51x, '+(Run OFF ', f12.6, 15x, ')', &
+ /, 51x, '-(Sea-Ice Acr', f12.6, 15x, ')', &
+ /, 29x, '= *BAL', f12.6, ' [mm w.e.]')
+ noSBal = noSBal + 1
+ if(noSBal >= 10) stop 'TOO MUCH SNOW MASS IMBALANCE'
+ endif
+#endif
+
+ ! +--Water Budget
+ ! + -------------
+#if(m0)
+ ! Canopy Water Cont. + Soil Water Cont.
+ Watsv0(ikl) = Watsv0(ikl) &
+ + Wats_0(ikl)
+ ! Canopy Forcing + Soil Forcing
+ Watsvd(ikl) = Watsvd(ikl) &
+ + Wats_d(ikl)
+ write(noUNIT, 5003) &
+ Wats_0(ikl), Wats_d(ikl), &
+ Wats_0(ikl) + Wats_d(ikl), Wats_1(ikl), &
+ Watsv0(ikl), Watsvd(ikl), &
+ Watsv0(ikl) + Watsvd(ikl), Wats_1(ikl) &
+ + rrCaSV(ikl)
+5003 format(' SOIL/SNOW (qSo) | Water, Time 0 |', &
+ ' Water, Forcing | Sum |', &
+ ' Water, Time 1 |', &
+ /, ' |', f13.3, ' [mm] |', &
+ f11.3, ' [mm] |', f13.3, ' [mm] |', &
+ f13.3, ' [mm] |', &
+ /, ' -----------------+-------------------+', &
+ '-----------------+-------------------+', &
+ '-------------------+', &
+ /, ' SOIL/SNOW/VEGET. | Water, Time 0 |', &
+ ' Water, Forcing | Sum |', &
+ ' Water, Time 1 |', &
+ /, ' |', f13.3, ' [mm] |', &
+ f11.3, ' [mm] |', f13.3, ' [mm] |', &
+ f13.3, ' [mm] |', &
+ /, ' -----------------+-------------------+', &
+ '-----------------+-------------------+', &
+ '-------------------+')
+
+ WatBal = Wats_1(ikl) + rrCaSV(ikl) &
+ - (Watsv0(ikl) + Watsvd(ikl))
+ if(abs(WatBal) > epsi) then
+ write(6, 6002) daHost, i___SV(lwriSV(ikl)), &
+ j___SV(lwriSV(ikl)), &
+ n___SV(lwriSV(ikl)), &
+ Wats_1(ikl), rrCaSV(ikl), &
+ Watsv0(ikl), Watsvd(ikl), WatBal, &
+ Wats_1(ikl), &
+ Wats_0(ikl), Wats_d(ikl), &
+ Wats_1(ikl) - Wats_0(ikl) - Wats_d(ikl)
+6002 format(30x, ' NEW Soil Water', 3x, ' Canopy Water', 3x, &
+ ' OLD SVAT Water', 4x, ' FRC SVAT Water', &
+ /, a18, 3i4, f15.6, ' + ', f15.6, ' - ', f15.6, &
+ ' - ', f15.6, ' ', 15x, ' ', &
+ /, 31x, '= ', f12.6, ' [mm] (Water Balance)', &
+ /, 30x, ' NEW Soil Water', 3x, ' ', 3x, &
+ ' OLD Soil Water', 4x, ' FRC Soil Water', &
+ /, 30x, f15.6, ' ', 15x, ' - ', f15.6, &
+ ' - ', f15.6, ' ', 15x, ' ', &
+ /, 31x, '= ', f12.6, ' [mm] (3 terms SUM)')
+ noWBal = noWBal + 1
+ if(noWBal >= 10) stop 'TOO MUCH WATER IMBALANCES'
+ endif
+#endif
+
+ ! +--Water/Temperature Profiles
+ ! + --------------------------
+#if(E0)
+ write(noUNIT, 5004)
+5004 format(' -----+--------+--+-----+--------+----+---+', &
+ '--------+----+---+--------+------+-+--------+--------+', &
+ /, ' n | z | dz | ro | eta |', &
+ ' T | G1 | G2 | Extinc | | HISTORY|', &
+ /, ' | [m] | [m] | [kg/m3]| [m3/m3]|', &
+ ' [K] | [-] | [-] | [-] | | [-] |', &
+ /, ' -----+--------+--------+--------+--------+', &
+ '--------+--------+--------+--------+--------+--------+')
+ write(noUNIT, 5005) rusnSV(ikl), albisv(ikl)
+5005 format(' | | | |W', f6.3, ' |', &
+ ' | | |A', f6.3, ' | | |')
+ write(noUNIT, 5015) &
+ (isn, zzsnsv(ikl, isn), dzsnSV(ikl, isn), &
+ ro__SV(ikl, isn), eta_SV(ikl, isn), &
+ TsisSV(ikl, isn), &
+ G1snSV(ikl, isn), G2snSV(ikl, isn), &
+ sEX_sv(ikl, isn), istoSV(ikl, isn), &
+ isn=isnoSV(ikl), 1, -1)
+5015 format((i5, ' |', 2(f7.3, ' |'), f7.1, ' |', &
+ f7.3, ' |', f7.2, ' |', 2(f7.1, ' |'), f7.3, ' |', &
+ 7x, ' |', i5, ' |'))
+ write(noUNIT, 5006)
+5006 format(' -----+--------+--------+--------+--------+', &
+ '--------+--------+--------+--------+--------+--------+')
+ write(noUNIT, 5007) TBr_sv(ikl), &
+ TvegSV(ikl), rrCaSV(ikl) * 1.e3, &
+ EvT_sv(ikl) * 86.4e3
+5007 format(' Brgh |', 4(8x, '|'), f7.2, ' | [micm] |', 4(8x, '|'), &
+ /, ' VEGE |', 4(8x, '|'), 2(f7.2, ' |'), 2(8x, '|'), &
+ f7.3, ' |', 8x, '|')
+ write(noUNIT, 5014)
+5014 format(' -----+--------+--------+--------+--------+', &
+ '--------+--------+--------+--------+--------+--------+', &
+ /, ' n | | dz | | eta |', &
+ ' T | | | | Root W.| W.Flow |', &
+ /, ' | | [m] | | [m3/m3]|', &
+ ' [K] | | | | [mm/d] | [mm/h] |', &
+ /, ' -----+--------+--------+--------+--------+', &
+ '--------+--------+--------+--------+--------+--------+')
+ do isl = 0, -nsol, -1
+ write(noUNIT, 5008) isl, LSdzsv(ikl) * dz_dSV(isl), &
+ eta_SV(ikl, isl), &
+ TsisSV(ikl, isl), &
+ 86.4e3 * Rootsv(ikl, isl), &
+ 3.6e3 * Khydsv(ikl, isl)
+ enddo
+5008 format((i5, ' |', 7x, ' |', f7.3, ' |', 7x, ' |', &
+ f7.3, ' |', f7.2, ' |', 2(7x, ' |'), 7x, ' |', &
+ f7.3, ' |', f7.2, ' |'))
+ write(noUNIT, 5006)
+ write(noUNIT, 5009) RnofSV(ikl) * 3.6e3
+5009 format(' |', 9(8x, '|'), f7.3, ' |')
+ write(noUNIT, 5006)
+ endif
+ enddo
+#endif
+ ! +..END .main.
+ return
+ endsubroutine SISVAT
diff --git a/MAR/code_mar/sisvat_bsn.f90 b/MAR/code_mar/sisvat_bsn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8c6711ffda572cc02f2420aee24cc8beeea4adc5
--- /dev/null
+++ b/MAR/code_mar/sisvat_bsn.f90
@@ -0,0 +1,104 @@
+#include "MAR_pp.def"
+subroutine SISVAT_BSn
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_BSn 04-apr-2020 MAR |
+ ! | subroutine SISVAT_BSn treats Snow Erosion |
+ ! | (not deposition anymore since 2-jun 2018) |
+ ! | |
+ ! | SISVAT_bsn computes the snow erosion mass according to both the |
+ ! | theoretical maximum erosion amount computed in SISVATesbl and the |
+ ! | availability of snow (currently in the uppermost snow layer only) |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # stdout | #sb: OUTPUT of Snow Erosion |
+ ! | | unit 6, subroutine SISVAT_BSn **ONLY** |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ===============
+
+ integer ikl, isn
+ real h_mmWE ! Eroded Snow Layer Min Thickness
+ real dbsaux(klonv) ! Drift Amount (Dummy Variable)
+ real dzweqo, dzweqn, bsno_x ! Conversion variables for erosion
+ real dz_new, rho_new
+ real snofOK ! Threshd Snow Fall
+ real Fac ! Correction factor for erosion
+ real densif ! Densification rate if erosion
+
+ ! +--DATA
+ ! + ====
+
+ data h_mmWE/0.01e00/ ! Eroded Snow Layer Min Thickness
+
+ ! +--EROSION
+ ! + =======
+
+ ! !do isn = nsno,2,-1
+ do ikl = 1, klonv
+
+ isn = isnoSV(ikl)
+ dzweqo = dzsnSV(ikl, isn) * ro__SV(ikl, isn) ! [kg/m2, mm w.e.]
+
+ bsno_x = min(0., dbs_SV(ikl))
+ ! Fac = min(1.,max(1-(ro__SV(ikl,isn)/700.),0.)**2)
+ ! Fac = min(1.,max(1-(qsnoSV(ikl)*1000/30.),0.))
+ ! bsno_x = bsno_x*Fac
+
+ dzweqn = dzweqo + bsno_x
+ dzweqn = max(dzweqn, h_mmWE)
+ dzweqn = min(dzweqn, dzweqo)
+ !XF
+ dbs_SV(ikl) = dbs_SV(ikl) + (dzweqo - dzweqn)
+ dbs_Er(ikl) = dbs_Er(ikl) + (dzweqo - dzweqn)
+ dzsnSV(ikl, isn) = dzweqn &
+ / max(epsi, ro__SV(ikl, isn))
+
+ ! ! Densification of the uppermost snow layer if erosion:
+ if((dzweqo - dzweqn) > 0 .and. &
+ dzsnSV(ikl, isn) > 0 .and. &
+ ro__SV(ikl, max(1, isnoSV(ikl))) < roBdSV) then
+
+ ! !characteristic time scale for drifting snow compaction set to 24h
+ ! !linear densification rate [kg/m3/s] over 24h
+ densif = (450.-frsno) / (3600 * 24)
+
+ ! !Attenuation of compaction rate from 450 to 500 kg/m3
+ Fac = 1 - ((ro__SV(ikl, max(1, isnoSV(ikl))) &
+ - roBdSV) / (500.-roBdSV))
+ Fac = max(0., min(1., Fac))
+
+ if(ro__SV(ikl, max(1, isnoSV(ikl))) > roBdSV) then
+ densif = densif * Fac
+ endif
+
+ rho_new = min(roBdSV, ro__SV(ikl, isn) + densif * dt__SV)
+ dz_new = dzsnSV(ikl, isn) * ro__SV(ikl, isn) / rho_new
+ ro__SV(ikl, isn) = rho_new
+ dzsnSV(ikl, isn) = dz_new
+ endif
+
+ if(dzsnSV(ikl, isn) > 0 .and. dzsnSV(ikl, isn) < 0.0001) then
+ dbs_SV(ikl) = dbs_SV(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ dbs_Er(ikl) = dbs_Er(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ dzsnSV(ikl, isn) = 0
+ ro__SV(ikl, isn) = 0
+ isnoSV(ikl) = max(0, isnoSV(ikl) - 1)
+ endif
+
+ enddo
+ ! !end do
+
+ return
+ENDsubroutine SISVAT_BSn
diff --git a/MAR/code_mar/sisvat_gsn.f90 b/MAR/code_mar/sisvat_gsn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f82acc3a7a4eb585d2ebf95800726e5816ede02e
--- /dev/null
+++ b/MAR/code_mar/sisvat_gsn.f90
@@ -0,0 +1,1054 @@
+#include "MAR_pp.def"
+subroutine SISVAT_GSn
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_GSn 20-09-2003 MAR |
+ ! | subroutine SISVAT_GSn simulates SNOW Metamorphism |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT / isnoSV = total Nb of Ice/Snow Layers |
+ ! | OUTPUT: iiceSV = total Nb of Ice Layers |
+ ! | ^^^^^^ istoSV = 0,...,5 : Snow History (see istdSV data) |
+ ! | |
+ ! | INPUT: TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+ ! | ^^^^^ & Snow Temperatures (layers 1,2,...,nsno) [K] |
+ ! | ro__SV : Soil/Snow Volumic Mass [kg/m3] |
+ ! | eta_SV : Soil/Snow Water Content [m3/m3] |
+ ! | slopSV : Surface Slope [-] |
+ ! | dzsnSV : Snow Layer Thickness [m] |
+ ! | dt__SV2 : Time Step [s] |
+ ! | |
+ ! | INPUT / G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+ ! | OUTPUT: G2snSV : Sphericity (>0) or Size of Snow Layer |
+ ! | ^^^^^^ |
+ ! | |
+ ! | Formalisme adopte pour la Representation des Grains: |
+ ! | Formalism for the Representation of Grains: |
+ ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! | |
+ ! | 1 - -1 Neige Fraiche |
+ ! | / \ | ------------- |
+ ! | / \ | Dendricite decrite par Dendricite |
+ ! | / \ | Dendricity et Sphericite |
+ ! | / \ | |
+ ! | 2---------3 - 0 described by Dendricity |
+ ! | and Sphericity |
+ ! | |---------| |
+ ! | 0 1 |
+ ! | Sphericite |
+ ! | Sphericity |
+ ! | |
+ ! | 4---------5 - |
+ ! | | | | |
+ ! | | | | Diametre (1/10eme de mm) (ou Taille) |
+ ! | | | | Diameter (1/10th of mm) (or Size ) |
+ ! | | | | |
+ ! | | | | Neige non dendritique |
+ ! | 6---------7 - --------------------- |
+ ! | decrite par Sphericite |
+ ! | et Taille |
+ ! | described by Sphericity |
+ ! | and Size |
+ ! | |
+ ! | Les Variables du Modele: |
+ ! | Model Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! | Cas Dendritique Cas non Dendritique |
+ ! | |
+ ! | G1snSV : Dendricite G1snSV : Sphericite |
+ ! | G2snSV : Sphericite G2snSV : Taille (1/10e mm) |
+ ! | Size |
+ ! | |
+ ! | Cas Dendritique/ Dendritic Case |
+ ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! | Dendricite(Dendricity) G1snSV |
+ ! | varie de -G1_dSV (-99 par defaut / etoile) a 0 |
+ ! | division par -G1_dSV pour obtenir des valeurs entre 1 et 0 |
+ ! | varies from -G1_dSV (default -99 / fresh snow) to 0 |
+ ! | division by -G1_dSV to obtain values between 1 and 0 |
+ ! | |
+ ! | Sphericite(Sphericity) G2snSV |
+ ! | varie de 0 (cas completement anguleux) |
+ ! | a G1_dSV (99 par defaut, cas spherique) |
+ ! | division par G1_dSV pour obtenir des valeurs entre 0 et 1 |
+ ! | varies from 0 (full faceted) to G1_dSV |
+ ! | |
+ ! | Cas non Dendritique / non Dendritic Case |
+ ! | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+ ! | Sphericite(Sphericity) G1snSV |
+ ! | varie de 0 (cas completement anguleux) |
+ ! | a G1_dSV (99 par defaut, cas spherique) |
+ ! | division par G1_dSV pour obtenir des valeurs entre 0 et 1 |
+ ! | varies from 0 (full faceted) to G1_dSV |
+ ! | |
+ ! | Taille (Size) G2snSV |
+ ! | superieure a ADSdSV (.4 mm) et ne fait que croitre |
+ ! | greater than ADSdSV (.4 mm) always increases |
+ ! | |
+ ! | Exemples: Points caracteristiques des Figures ci-dessus |
+ ! | ^^^^^^^^^ |
+ ! | |
+ ! | G1snSV G2snSV dendricite sphericite taille |
+ ! | dendricity sphericity size |
+ ! | ------------------------------------------------------------------ |
+ ! | [1/10 mm] |
+ ! | 1 -G1_dSV sph3SN 1 0.5 |
+ ! | 2 0 0 0 0 |
+ ! | 3 0 G1_dSV 0 1 |
+ ! | 4 0 ADSdSV 0 4. |
+ ! | 5 G1_dSV ADSdSV-vsphe1 1 3. |
+ ! | 6 0 -- 0 -- |
+ ! | 7 G1_dSV -- 1 -- |
+ ! | |
+ ! | par defaut: G1_dSV=99. |
+ ! | sph3SN=50. |
+ ! | ADSdSV= 4. |
+ ! | vsphe1=1. |
+ ! | |
+ ! | Methode: |
+ ! | ^^^^^^^^ |
+ ! | 1. Evolution Types de Grains selon Lois de Brun et al. (1992): |
+ ! | Grain metamorphism according to Brun et al. (1992): |
+ ! | Plusieurs Cas sont a distiguer / the different Cases are: |
+ ! | 1.1 Metamorphose Neige humide / wet Snow |
+ ! | 1.2 Metamorphose Neige seche / dry Snow |
+ ! | 1.2.1 Gradient faible / low Temperature Gradient |
+ ! | 1.2.2 Gradient moyen / moderate Temperature Gradient |
+ ! | 1.2.3 Gradient fort / high Temperature Gradient |
+ ! | Dans chaque Cas on separe Neige Dendritique et non Dendritique |
+ ! | le Passage Dendritique -> non Dendritique |
+ ! | se fait lorsque G1snSV devient > 0 |
+ ! | the Case of Dentritic or non Dendritic Snow is treated separately |
+ ! | the Limit Dentritic -> non Dendritic is reached when G1snSV > 0 |
+ ! | |
+ ! | 2. Tassement: Loi de Viscosite adaptee selon le Type de Grains |
+ ! | Snow Settling: Viscosity depends on the Grain Type |
+ ! | |
+ ! | 3. Update Variables historiques (cas non dendritique seulement) |
+ ! | nhSNow defaut |
+ ! | 0 Cas normal |
+ ! | istdSV(1) 1 Grains anguleux / faceted cristal |
+ ! | istdSV(2) 2 Grains ayant ete en presence d eau liquide |
+ ! | mais n'ayant pas eu de caractere anguleux / |
+ ! | liquid water and no faceted cristals before |
+ ! | istdSV(3) 3 Grains ayant ete en presence d eau liquide |
+ ! | ayant eu auparavant un caractere anguleux / |
+ ! | liquid water and faceted cristals before |
+ ! | |
+ ! | REFER. : Brun et al. 1989, J. Glaciol 35 pp. 333--342 |
+ ! | ^^^^^^^^ Brun et al. 1992, J. Glaciol 38 pp. 13-- 22 |
+ ! | (CROCUS Model, adapted to MAR at CEN by H.Gallee) |
+ ! | |
+ ! | REFER. : Marbouty, D. 1980, J. Glaciol 26 pp. xxx--xxx |
+ ! | ^^^^^^^^ (CROCUS Model, adapted to MAR at CEN by H.Gallee) |
+ ! | (for angular shapes) |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SISVAT_GSn.vp | #vp: OUTPUT/Verification: Snow Properties |
+ ! | | unit 47, subroutines SISVAT_zSn, _GSn |
+ ! | # stdout | #wp: OUTPUT/Verification: Snow Properties |
+ ! | | unit 6, subroutine SISVAT_GSn |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use mardim
+ use margrd
+ ! +--INPUT/OUTPUT
+ ! + ------------
+ use marxsv
+
+ implicit none
+
+ ! +--OUTPUT
+ ! + ------
+ integer i, j, k, m
+ integer dt__SV2
+
+ ! +--Local Variables
+ ! + ================
+ logical vector
+ integer ikl
+ integer isn, isnp
+ integer istoOK
+ ! G1_bak, G2_bak : Old Values of G1, G2
+ real G1_bak, G2_bak
+ ! ro_dry : Dry Density [g/cm3]
+ real ro_dry(klonv, nsno)
+ ! etaSno : Liquid Water Content [g/cm2]
+ real etaSno(klonv, nsno)
+ ! SnMass : Snow Mass [kg/m2]
+ real SnMass(klonv)
+ ! dTsndz : Temperature Gradient
+ real dTsndz
+ ! sWater : Water Content [%]
+ real sWater
+ real exp1Wa
+ ! dDENDR : Dendricity Increment
+ real dDENDR
+ ! DENDRn : Normalized Dendricity
+ real DENDRn
+ ! SPHERn : Normalized Sphericity
+ real SPHERn
+ ! Wet_OK : Wet Metamorphism Switch
+ real Wet_OK
+ real OK__DE
+ ! OK__wd : New G*, from wet Dendritic
+ real OK__wd
+ ! G1__wd : New G1, from wet Dendritic
+ real G1__wd
+ ! G2__wd : New G2, from wet Dendritic
+ real G2__wd
+ real OKlowT
+ real facVap
+ real OK_ldd
+ real G1_ldd
+ real G2_ldd
+ real DiamGx
+ real DiamOK
+ real No_Big
+ real dSPHER
+ real SPHER0
+ real SPHbig
+ real G1_lds
+ real OK_mdT
+ real OKmidT
+ real OKhigT
+ real OK_mdd
+ real G1_mdd
+ real G2_mdd
+ real G1_mds
+ real OK_hdd
+ real G1_hdd
+ real G2_hdd
+ real OK_hds
+ real G1_hds
+ real T1__OK, T2__OK
+ real T3_xOK, T3__OK, T3_nOK
+ real ro1_OK, ro2_OK
+ real dT1_OK, dT2_OK, dT3xOK, dT3_OK
+ real dT4xOK, dT4_OK, dT4nOK, AngSno
+ real G2_hds, SphrOK, HISupd
+ real H1a_OK, H1b_OK, H1__OK
+ real H23aOK, H23bOK, H23_OK
+ real H2__OK, H3__OK
+ real H45_OK, H4__OK, H5__OK
+ real ViscSn, OK_Liq, OK_Ang, OKxLiq
+ real dSnMas, dzsnew, rosnew, rosmax, smb_old, smb_new
+ real zn_old, zn_new
+
+ ! epsi5 : Alpha ev67 single precision
+ real epsi5
+ ! vdiam1 : Small Grains Min.Diam.[.0001m]
+ real vdiam1
+ ! vdiam2 : Spher.Variat.Max Diam. [mm]
+ real vdiam2
+ ! vdiam3 : Min.Diam.|Limit Spher. [mm]
+ real vdiam3
+ ! vdiam4 : Min.Diam.|Viscosity Change
+ real vdiam4
+ ! vsphe1 : Max Sphericity
+ real vsphe1
+ ! vsphe2 : Low T Metamorphism Coeff.
+ real vsphe2
+ ! vsphe3 : Max.Sphericity (history=1)
+ real vsphe3
+ ! vsphe4 : Min.Sphericity=>history=1
+ real vsphe4
+ ! vtang : Temperature Contribution
+ real vtang1, vtang2, vtang3, vtang4
+ real vtang5, vtang6, vtang7, vtang8
+ real vtang9, vtanga, vtangb, vtangc
+ ! vrang1, vrang2 : Density Contribution
+ real vrang1, vrang2
+ ! vgang : Grad(T) Contribution
+ real vgang1, vgang2, vgang3, vgang4
+ real vgang5, vgang6, vgang7, vgang8
+ real vgang9, vganga, vgangb, vgangc
+ ! vgran6 : Max.Sphericity for Settling
+ real vgran6
+ ! vtelv1 : Threshold | history = 2, 3
+ real vtelv1
+ ! vvap1 : Vapor Pressure Coefficient
+ real vvap1
+ ! vvap2 : Vapor Pressure Exponent
+ real vvap2
+ ! vgrat1 : Boundary weak/mid grad(T)
+ real vgrat1
+ ! vgrat2 : Boundary mid/strong grad(T)
+ real vgrat2
+ ! vfi : PHI, strong grad(T)
+ real vfi
+ ! vvisc : Viscosity Coefficients
+ real vvisc1, vvisc2, vvisc3, vvisc4
+ ! vvisc5, vvisc6, vvisc7 : id., wet Snow
+ real vvisc5, vvisc6, vvisc7
+ ! Wet Snow Density Influence
+ real rovisc
+ ! vdz3 : Maximum Layer Densification
+ real vdz3
+ ! OK__ws : New G2
+ real OK__ws
+ ! G1__ws : New G1, from wet Spheric
+ real G1__ws
+ ! G2__ws : New G2, from wet Spheric
+ real G2__ws
+ ! husi : Constants for New G2
+ real husi_0, husi_1, husi_2, husi_3
+ ! vtail : Constants for New G2
+ real vtail1, vtail2
+ ! frac_j : Time Step [Day]
+ real frac_j
+ ! vdent1 : Wet Snow Metamorphism
+ real vdent1
+ ! nvdent : Coefficients for Dendricity
+ integer nvdent1
+ integer nvdent2
+
+ ! +--Snow Properties: IO
+ ! + ~~~~~~~~~~~~~~~~~~~
+#if(vp)
+ real G_curr(18), Gcases(18)
+ common / GSnLOC / Gcases
+#endif
+#if(wp)
+ real D__MAX
+ common / GSnMAX / D__MAX
+ data D__MAX/4.00/
+#endif
+
+ ! +--DATA
+ ! + ====
+ data vector/.true./ ! Vectorization Switch
+ data vdent1/0.5e8/ ! Wet Snow Metamorphism !XF tuned for Greenland (2.e8=old value)
+ data nvdent1/3/ ! nvdent1, nvdent2 : Coefficients for Dendricity
+ data nvdent2/16/
+ data husi_0/20./ ! 10 * 2
+ data husi_1/0.23873/ ! (3/4) /pi
+ data husi_2/4.18880/ ! (4/3) *pi
+ data husi_3/0.33333/ ! 1/3
+ data vtail1/1.28e-08/ ! Wet Metamorphism
+ data vtail2/4.22e-10/ ! (NON Dendritic / Spheric)
+ data epsi5/1.0e-5/
+ data vdiam1/4.0/ ! Small Grains Min.Diameter
+ data vdiam2/0.5/ ! Spher.Variat.Max Diam.[mm]
+ data vdiam3/3.0/ ! Min.Diam.|Limit Spher.[mm]
+ data vdiam4/2.0/ ! Min.Diam.|Viscosity Change
+ data vsphe1/1.0/ ! Max Sphericity
+ data vsphe2/1.0e9/ ! Low T Metamorphism Coeff.
+ data vsphe3/0.5/ ! Max.Sphericity (history=1)
+ data vsphe4/0.1/ ! Min.Sphericity=>history=1
+ data vgran6/51./ ! Max.Sphericity for Settling
+ data vtelv1/5.e-1/ ! Threshold | history = 2, 3
+ data vvap1/-6.e3/ ! Vapor Pressure Coefficient
+ data vvap2/0.4/ ! Vapor Pressure Exponent
+ data vgrat1/0.05/ ! Boundary weak/mid grad(T)
+ data vgrat2/0.15/ ! Boundary mid/strong grad(T)
+ data vfi/0.09/ ! PHI, strong grad(T)
+ ! vvisc : Viscosity Coefficients
+ data vvisc1/0.70/
+ data vvisc2/1.11e5/
+ data vvisc3/23.00/
+ data vvisc4/0.10/
+ ! vvisc5 : id., wet Snow
+ data vvisc5/1.00/
+ data vvisc6/2.00/
+ data vvisc7/10.00/
+ ! rovisc : Wet Snow Density Influence
+ data rovisc/0.25/
+ ! vdz3 : Maximum Layer Densification
+ data vdz3/0.30/
+
+ ! +--DATA (Coefficient Fonction fort Gradient Marbouty)
+ ! + --------------------------------------------------
+ ! vtang : Temperature Contribution
+ data vtang1/40.0/
+ data vtang2/6.0/
+ data vtang3/22.0/
+ data vtang4/0.7/
+ data vtang5/0.3/
+ data vtang6/6.0/
+ data vtang7/1.0/
+ data vtang8/0.8/
+ data vtang9/16.0/
+ data vtanga/0.2/
+ data vtangb/0.2/
+ data vtangc/18.0/
+ ! vrang : Density Contribution
+ data vrang1/0.40/
+ data vrang2/0.15/
+ ! vgang : Grad(T) Contribution
+ data vgang1/0.70/
+ data vgang2/0.25/
+ data vgang3/0.40/
+ data vgang4/0.50/
+ data vgang5/0.10/
+ data vgang6/0.15/
+ data vgang7/0.10/
+ data vgang8/0.55/
+ data vgang9/0.65/
+ data vganga/0.20/
+ data vgangb/0.85/
+ data vgangc/0.15/
+
+ ! +-- 1. Metamorphoses dans les Strates
+ ! + Metamorphism
+ ! + ==============================
+
+ dt__SV2 = dt
+ frac_j = dt__SV2 / 86400. ! Time Step [Day]
+
+ zn4_SV = 0
+
+ ! +-- 1.1 Initialisation: teneur en eau liquide et gradient de temperature
+ ! + ------------------ liquid water content and temperature gradient
+
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+
+ ! Dry Density [g/cm3]
+ ro_dry(ikl, isn) = 1.e-3 * ro__SV(ikl, isn) &
+ * (1.-eta_SV(ikl, isn))
+ ! Liquid Water Content [g/cm2]
+ etaSno(ikl, isn) = 1.e-1 * dzsnSV(ikl, isn) &
+ * ro__SV(ikl, isn) &
+ * eta_SV(ikl, isn)
+ enddo
+ enddo
+
+ !!$OMP PARALLEL do default(firstprivate) &
+ !!$OMP shared (/xSISVAT_I/,/xSISVAT_R/,/SoR0SV/,/SoI0SV/,/Sn_dSV/)
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ isnp = min(isn + 1, isnoSV(ikl))
+
+ dTsndz = abs((TsisSV(ikl, isnp) - TsisSV(ikl, isn - 1)) * 2.e-2 &
+ / max(((dzsnSV(ikl, isnp) + dzsnSV(ikl, isn)) &
+ * (isnp - isn) &
+ + (dzsnSV(ikl, isn) + dzsnSV(ikl, isn - 1))), epsi))
+ ! +... Factor 1.d-2 for Conversion K/m --> K/cm
+
+ ! +-- 1.2 Metamorphose humide
+ ! + Wet Snow Metamorphism
+ ! + ---------------------
+
+ Wet_OK = max(zero, sign(unun, eta_SV(ikl, isn) - epsi))
+
+ ! +-- Vitesse de diminution de la dendricite
+ ! + Rate of the dendricity decrease
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ sWater = 1.d-1 * ro__SV(ikl, isn) * eta_SV(ikl, isn) &
+ / max(epsi, ro_dry(ikl, isn))
+ ! +... sWater:Water Content [%]
+ ! + 1.d-1= 1.d2(1->%) * 1.d-3(ro__SV*eta_SV:kg/m3->g/cm3)
+
+ exp1Wa = sWater**nvdent1
+ dDENDR = max(exp1Wa / nvdent2, vdent1 * exp(vvap1 / TfSnow))
+
+ ! +-- 1.2.1 Cas dendritique/dendritic Case
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ OK__wd = max(zero, &
+ sign(unun, -G1snSV(ikl, isn) - epsi)) !
+
+ DENDRn = -G1snSV(ikl, isn) / G1_dSV ! Normalized Dendricity (+)
+ SPHERn = G2snSV(ikl, isn) / G1_dSV ! Normalized Sphericity
+ DENDRn = DENDRn - dDENDR * frac_j ! New Dendricity (+)
+ SPHERn = SPHERn + dDENDR * frac_j ! New Sphericity
+
+ OK__DE = max(zero, sign(unun, DENDRn - epsi)) ! Dendr. -> Spheric
+
+ ! Dendritic
+ ! Dendr. -> Spheric
+ G1__wd = OK__DE * (-DENDRn * G1_dSV) &
+ + (1.-OK__DE) * min(G1_dSV, SPHERn * G1_dSV)
+ ! Spheric
+ ! Spher. -> Size
+ G2__wd = OK__DE * min(G1_dSV, SPHERn * G1_dSV) &
+ + (1.-OK__DE) * (ADSdSV - min(SPHERn, vsphe1))
+
+ ! +-- 1.2.2 Cas non dendritique non completement spherique
+ ! + Evolution de la Sphericite seulement.
+ ! + Non dendritic and not completely spheric Case
+ ! + Evolution of Sphericity only (not size)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ OK__ws = max(zero, &
+ sign(unun, G1_dSV &
+ - epsi5 &
+ - G1snSV(ikl, isn)))
+
+ SPHERn = G1snSV(ikl, isn) / G1_dSV
+ SPHERn = SPHERn + dDENDR * frac_j
+ G1__ws = min(G1_dSV, SPHERn * G1_dSV)
+
+ ! +-- 1.2.3 Cas non dendritique et spherique / non dendritic and spheric
+ ! + Evolution de la Taille seulement / Evolution of Size only
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ G2__ws = husi_0 &
+ * (husi_1 &
+ * (husi_2 * (G2snSV(ikl, isn) / husi_0)**3 &
+ + (vtail1 + vtail2 * exp1Wa) * dt__SV2)) &
+ **husi_3
+
+ ! +-- 1.3 Metamorposes seches / Dry Metamorphism
+ ! + --------------------------------------
+
+ ! +-- 1.3.1 Calcul Metamorphose faible/low Gradient (0.00-0.05 deg/cm)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ OKlowT = max(zero, &
+ sign(unun, vgrat1 &
+ - dTsndz))
+
+ facVap = exp(vvap1 / TsisSV(ikl, isn))
+
+ ! +-- 1.3.1.1 Cas dendritique / dendritic Case
+
+ OK_ldd = max(zero, &
+ sign(unun, -G1snSV(ikl, isn) &
+ - epsi)) !
+
+ DENDRn = -G1snSV(ikl, isn) / G1_dSV
+ SPHERn = G2snSV(ikl, isn) / G1_dSV
+ DENDRn = DENDRn - vdent1 * facVap * frac_j
+ SPHERn = SPHERn + vsphe2 * facVap * frac_j
+ ! if 1.,
+ ! NO change
+ ! Dendr. -> Spheric
+ OK__DE = max(zero, &
+ sign(unun, DENDRn &
+ - epsi))
+ ! Dendritic
+ ! Dendr. -> Spheric
+ G1_ldd = OK__DE * (-DENDRn * G1_dSV) &
+ + (1.-OK__DE) * min(G1_dSV, SPHERn * G1_dSV)
+ ! Spheric
+ ! Spher. -> Size
+ G2_ldd = OK__DE * min(G1_dSV, SPHERn * G1_dSV) &
+ + (1.-OK__DE) * (ADSdSV - min(SPHERn, vsphe1))
+
+ ! +-- 1.3.1.2 Cas non dendritique / non dendritic Case
+
+ SPHERn = G1snSV(ikl, isn) / G1_dSV
+ DiamGx = G2snSV(ikl, isn) * 0.1
+ ! zero if istoSV = 1
+ istoOK = min(abs(istoSV(ikl, isn) - &
+ istdSV(1)), 1)
+ DiamOK = max(zero, sign(unun, vdiam2 - DiamGx))
+ No_Big = istoOK + DiamOK
+ No_Big = min(No_Big, unun)
+
+ dSPHER = vsphe2 * facVap * frac_j
+ ! small grains
+ SPHER0 = SPHERn + dSPHER
+ ! big grains (history = 2 or 3)
+ SPHbig = SPHERn + dSPHER &
+ * exp(min(zero, vdiam3 - G2snSV(ikl, isn)))
+ ! limited sphericity
+ SPHbig = min(vsphe3, SPHbig)
+ SPHERn = No_Big * SPHER0 &
+ + (1.-No_Big) * SPHbig
+
+ G1_lds = min(G1_dSV, SPHERn * G1_dSV)
+
+ ! +-- 1.3.2 Calcul Metamorphose Gradient Moyen/Moderate (0.05-0.15)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ OK_mdT = max(zero, &
+ sign(unun, vgrat2 &
+ - dTsndz))
+ OKmidT = OK_mdT * (1.-OKlowT)
+ OKhigT = (1.-OK_mdT) * (1.-OKlowT)
+
+ facVap = vdent1 * exp(vvap1 / TsisSV(ikl, isn)) &
+ * (1.e2 * dTsndz)**vvap2
+
+ ! +-- 1.3.2.1 cas dendritique / dendritic case.
+
+ OK_mdd = max(zero, &
+ sign(unun, -G1snSV(ikl, isn) &
+ - epsi))
+
+ DENDRn = -G1snSV(ikl, isn) / G1_dSV
+ SPHERn = G2snSV(ikl, isn) / G1_dSV
+ DENDRn = DENDRn - facVap * frac_j
+ SPHERn = SPHERn - facVap * frac_j
+ ! if 1.,
+ ! NO change
+ ! Dendr. -> Spheric
+ OK__DE = max(zero, &
+ sign(unun, DENDRn &
+ - epsi))
+ ! Dendritic
+ ! Dendr. -> Spheric
+ G1_mdd = OK__DE * (-DENDRn * G1_dSV) &
+ + (1.-OK__DE) * max(zero, SPHERn * G1_dSV)
+ ! Spheric
+ ! Spher. -> Size
+ G2_mdd = OK__DE * max(zero, SPHERn * G1_dSV) &
+ + (1.-OK__DE) * (ADSdSV - max(SPHERn, zero))
+
+ ! +-- 1.3.2.2 Cas non dendritique / non dendritic Case
+
+ SPHERn = G1snSV(ikl, isn) / G1_dSV
+ SPHERn = SPHERn - facVap * frac_j
+ G1_mds = max(zero, SPHERn * G1_dSV)
+
+ ! +-- 1.3.3 Calcul Metamorphose fort / high Gradient
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ facVap = vdent1 * exp(vvap1 / TsisSV(ikl, isn)) &
+ * (1.e2 * dTsndz)**vvap2
+
+ ! +-- 1.3.3.1 Cas dendritique / dendritic Case
+
+ OK_hdd = max(zero, &
+ sign(unun, -G1snSV(ikl, isn) &
+ - epsi))
+
+ DENDRn = -G1snSV(ikl, isn) / G1_dSV
+ SPHERn = G2snSV(ikl, isn) / G1_dSV
+ DENDRn = DENDRn - facVap * frac_j
+ ! Non dendritic and angular
+ ! if 1.,
+ ! NO change
+ ! Dendr. -> Spheric
+ SPHERn = SPHERn - facVap * frac_j
+ OK__DE = max(zero, &
+ sign(unun, DENDRn &
+ - epsi))
+ ! Dendritic
+ ! Dendr. -> Spheric
+ G1_hdd = OK__DE * (-DENDRn * G1_dSV) &
+ + (1.-OK__DE) * max(zero, SPHERn * G1_dSV)
+ ! Spheric
+ ! Spher. -> Size
+ G2_hdd = OK__DE * max(zero, SPHERn * G1_dSV) &
+ + (1.-OK__DE) * (ADSdSV - max(SPHERn, zero))
+
+ ! +-- 1.3.3.2 Cas non dendritique non completement anguleux.
+ ! + non dendritic and spericity gt. 0
+
+ OK_hds = max(zero, &
+ sign(unun, G1snSV(ikl, isn) &
+ - epsi))
+
+ SPHERn = G1snSV(ikl, isn) / G1_dSV
+ SPHERn = SPHERn - facVap * frac_j
+ G1_hds = max(zero, SPHERn * G1_dSV)
+
+ ! +-- 1.3.3.3 Cas non dendritique et anguleux
+ ! + dendritic and spericity = 0.
+
+ T1__OK = max(zero, sign(unun, TsisSV(ikl, isn) - TfSnow + vtang1))
+ T2__OK = max(zero, sign(unun, TsisSV(ikl, isn) - TfSnow + vtang2))
+ T3_xOK = max(zero, sign(unun, TsisSV(ikl, isn) - TfSnow + vtang3))
+ T3__OK = T3_xOK * (1.-T2__OK)
+ T3_nOK = (1.-T3_xOK) * (1.-T2__OK)
+ ro1_OK = max(zero, sign(unun, vrang1 - ro_dry(ikl, isn)))
+ ro2_OK = max(zero, sign(unun, ro_dry(ikl, isn) - vrang2))
+ dT1_OK = max(zero, sign(unun, vgang1 - dTsndz))
+ dT2_OK = max(zero, sign(unun, vgang2 - dTsndz))
+ dT3xOK = max(zero, sign(unun, vgang3 - dTsndz))
+ dT3_OK = dT3xOK * (1.-dT2_OK)
+ dT4xOK = max(zero, sign(unun, vgang4 - dTsndz))
+ dT4_OK = dT4xOK * (1.-dT3_OK) &
+ * (1.-dT2_OK)
+ dT4nOK = (1.-dT4xOK) * (1.-dT3_OK) &
+ * (1.-dT2_OK)
+
+ ! +-- Influence de la Temperature /Temperature Influence
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ AngSno = &
+ ! 11
+ T1__OK &
+ ! 12
+ * (T2__OK * (vtang4 + vtang5 * (TfSnow - TsisSV(ikl, isn)) &
+ / vtang6) &
+ ! 13
+ + T3__OK * (vtang7 - vtang8 * (TfSnow - vtang2 - TsisSV(ikl, isn)) &
+ / vtang9) &
+ ! 14
+ + T3_nOK * (vtanga - vtangb * (TfSnow - vtang3 - TsisSV(ikl, isn)) &
+ / vtangc)) &
+ * ro1_OK &
+ * (ro2_OK * (1.-(ro_dry(ikl, isn) - vrang2) &
+ / (vrang1 - vrang2)) &
+ + 1.-ro2_OK) &
+ ! 15
+ * (dT1_OK * (dT2_OK * vgang5 * (dTsndz - vgang6) &
+ / (vgang2 - vgang6) &
+ ! 16
+ + dT3_OK * vgang7 &
+ ! 17
+ + dT4_OK * vgang9 &
+ ! 18
+ + dT4nOK * vgangb) &
+ + 1.-dT1_OK) &
+ + ro1_OK &
+ * dT1_OK * (dT3_OK * vgang8 * (dTsndz - vgang2) &
+ / (vgang3 - vgang2) &
+ + dT4_OK * vganga * (dTsndz - vgang3) &
+ / (vgang4 - vgang3) &
+ + dT4nOK * vgangc * (dTsndz - vgang4) &
+ / (vgang1 - vgang4))
+
+ G2_hds = G2snSV(ikl, isn) + 1.d2 * AngSno * vfi * frac_j
+
+ ! +--New Properties
+ ! + --------------
+
+ G1_bak = G1snSV(ikl, isn)
+ G2_bak = G2snSV(ikl, isn)
+
+ ! 1
+ G1snSV(ikl, isn) = Wet_OK * (OK__wd * G1__wd &
+ ! 2
+ + (1.-OK__wd) * OK__ws * G1__ws &
+ ! 3
+ + (1.-OK__wd) * (1.-OK__ws) * G1_bak) &
+ !
+ + (1.-Wet_OK) &
+ ! 4
+ * (OKlowT * (OK_ldd * G1_ldd &
+ ! 5
+ + (1.-OK_ldd) * G1_lds) &
+ ! 6
+ + OKmidT * (OK_mdd * G1_mdd &
+ ! 7
+ + (1.-OK_mdd) * G1_mds) &
+ ! 8
+ + OKhigT * (OK_hdd * G1_hdd &
+ ! 9
+ + (1.-OK_hdd) * OK_hds * G1_hds &
+ ! 10
+ + (1.-OK_hdd) * (1.-OK_hds) * G1_bak))
+
+ !XF
+ if(G1snSV(ikl, isn) < 0.1) &
+ G2_hds = G2snSV(ikl, isn) + 1.d1 * AngSno * vfi * frac_j
+ !XF
+
+ ! 1
+ G2snSV(ikl, isn) = Wet_OK * (OK__wd * G2__wd &
+ ! 2
+ + (1.-OK__wd) * OK__ws * G2_bak &
+ ! 3
+ + (1.-OK__wd) * (1.-OK__ws) * G2__ws) &
+ !
+ + (1.-Wet_OK) &
+ ! 4
+ * (OKlowT * (OK_ldd * G2_ldd &
+ ! 5
+ + (1.-OK_ldd) * G2_bak) &
+ ! 6
+ + OKmidT * (OK_mdd * G2_mdd &
+ ! 7
+ + (1.-OK_mdd) * G2_bak) &
+ ! 8
+ + OKhigT * (OK_hdd * G2_hdd &
+ ! 9
+ + (1.-OK_hdd) * OK_hds * G2_bak &
+ ! 10
+ + (1.-OK_hdd) * (1.-OK_hds) * G2_hds))
+#if(vp)
+ ! +--Snow Properties: IO Set Up
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~
+ G_curr(1) = Wet_OK * OK__wd
+ G_curr(2) = Wet_OK * (1.-OK__wd) * OK__ws
+ G_curr(3) = Wet_OK * (1.-OK__wd) * (1.-OK__ws)
+ G_curr(4) = (1.-Wet_OK) * OKlowT * OK_ldd
+ G_curr(5) = (1.-Wet_OK) * OKlowT * (1.-OK_ldd)
+ G_curr(6) = (1.-Wet_OK) * OKmidT * OK_mdd
+ G_curr(7) = (1.-Wet_OK) * OKmidT * (1.-OK_mdd)
+ G_curr(8) = (1.-Wet_OK) * OKhigT * OK_hdd
+ G_curr(9) = (1.-Wet_OK) * OKhigT * (1.-OK_hdd) * OK_hds
+ G_curr(10) = (1.-Wet_OK) * OKhigT * (1.-OK_hdd) * (1.-OK_hds)
+ G_curr(11) = T1__OK * G_curr(10)
+ G_curr(12) = T2__OK * G_curr(10)
+ G_curr(13) = T3__OK * G_curr(10)
+ G_curr(14) = T3_nOK * G_curr(10)
+ G_curr(15) = ro1_OK * dT1_OK * dT2_OK * G_curr(10)
+ G_curr(16) = ro1_OK * dT1_OK * dT3_OK * G_curr(10)
+ G_curr(17) = ro1_OK * dT1_OK * dT4_OK * G_curr(10)
+ G_curr(18) = ro1_OK * dT1_OK * dT4nOK * G_curr(10)
+ Gcases(1) = max(Gcases(1), G_curr(1))
+ Gcases(2) = max(Gcases(2), G_curr(2))
+ Gcases(3) = max(Gcases(3), G_curr(3))
+ Gcases(4) = max(Gcases(4), G_curr(4))
+ Gcases(5) = max(Gcases(5), G_curr(5))
+ Gcases(6) = max(Gcases(6), G_curr(6))
+ Gcases(7) = max(Gcases(7), G_curr(7))
+ Gcases(8) = max(Gcases(8), G_curr(8))
+ Gcases(9) = max(Gcases(9), G_curr(9))
+ Gcases(10) = max(Gcases(10), G_curr(10))
+ Gcases(11) = max(Gcases(11), G_curr(11))
+ Gcases(12) = max(Gcases(12), G_curr(12))
+ Gcases(13) = max(Gcases(13), G_curr(13))
+ Gcases(14) = max(Gcases(14), G_curr(14))
+ Gcases(15) = max(Gcases(15), G_curr(15))
+ Gcases(16) = max(Gcases(16), G_curr(16))
+ Gcases(17) = max(Gcases(17), G_curr(17))
+ Gcases(18) = max(Gcases(18), G_curr(18))
+ ! +--Snow Properties: IO
+ ! + ~~~~~~~~~~~~~~~~~~~
+ if(isn <= isnoSV(ikl)) &
+ write(47, 471) isn, isnoSV(ikl), &
+ TsisSV(ikl, isn), ro__SV(ikl, isn), eta_SV(ikl, isn), &
+ G1_bak, G2_bak, istoSV(ikl, isn), &
+ dTsndz, &
+ (k, k=1, 18), &
+ (G_curr(k), k=1, 18), &
+ (Gcases(k), k=1, 18), &
+ Wet_OK, OK__wd, G1__wd, G2__wd, &
+ 1.-OK__wd, OK__ws, G1__ws, 1.-OK__ws, G2__ws, &
+ 1.-Wet_OK, OKlowT, OK_ldd, G1_ldd, G2_ldd, &
+ 1.-OK_ldd, G1_lds, &
+ OKmidT, OK_mdd, G1_mdd, G1_mdd, &
+ 1.-OK_mdd, G1_mds, &
+ OKhigT, OK_hdd, G1_hdd, G2_hdd, &
+ 1.-OK_hdd, OK_hds, G1_hds, &
+ 1.-OK_hds, G2_hds, &
+ G1snSV(ikl, isn), &
+ G2snSV(ikl, isn)
+471 format( &
+ /, ' isn = ', i4, 6x, '(MAX.:', i4, ')', &
+ /, ' T = ', f8.3, &
+ /, ' ro = ', f8.3, &
+ /, ' eta = ', f8.3, &
+ /, ' G1 = ', f8.3, &
+ /, ' G2 = ', f8.3, &
+ /, ' Histor. = ', i4, &
+ /, ' Grad(T) = ', f8.3, ' ', 18i3, &
+ /, ' Current Case: ', 18f3.0, &
+ /, ' Cases performed: ', 18f3.0, &
+ /, ' ------------------------------------------------------------', &
+ '-----------+------------------+------------------+', &
+ /, ' Status ', &
+ ' | G1 | G2 |', &
+ /, ' ------------------------------------------------------------', &
+ '-----------+------------------+------------------+', &
+ /, ' Wet_OK: ', f8.3, ' OK__wd: ', f8.3, ' ', &
+ ' | G1__wd: ', f8.3, ' | G2__wd: ', f8.5, ' |', &
+ /, ' 1.-OK__wd: ', f8.3, ' OK__ws', &
+ ': ', f8.3, ' | G1__ws: ', f8.3, ' | |', &
+ /, ' 1.-OK__ws', &
+ ': ', f8.3, ' | | G2__ws: ', f8.5, ' |', &
+ /, ' 1.-Wet_OK: ', f8.3, ' OKlowT: ', f8.3, ' OK_ldd: ', f8.3, ' ', &
+ ' | G1_ldd: ', f8.3, ' | G2_ldd: ', f8.5, ' |', &
+ /, ' 1.-OK_ldd: ', f8.3, ' ', &
+ ' | G1_lds: ', f8.3, ' | |', &
+ /, ' OKmidT: ', f8.3, ' OK_mdd: ', f8.3, ' ', &
+ ' | G1_mdd: ', f8.3, ' | G2_mdd: ', f8.5, ' |', &
+ /, ' 1.-OK_mdd: ', f8.3, ' ', &
+ ' | G1_mds: ', f8.3, ' | |', &
+ /, ' OKhigT: ', f8.3, ' OK_hdd: ', f8.3, ' ', &
+ ' | G1_hdd: ', f8.3, ' | G2_hdd: ', f8.5, ' |', &
+ /, ' 1.-OK_hdd: ', f8.3, ' OK_hds', &
+ ': ', f8.3, ' | G1_hds: ', f8.3, ' | |', &
+ /, ' 1.-OK_hds', &
+ ': ', f8.3, ' | | G2_hds: ', f8.5, ' |', &
+ /, ' ------------------------------------------------------------', &
+ '-----------+------------------+------------------+', &
+ /, ' ', &
+ ' | ', f8.3, ' | ', f8.5, ' |', &
+ /, ' ------------------------------------------------------------', &
+ '-----------+------------------+------------------+')
+#endif
+ enddo
+ enddo
+ !!$OMP END PARALLEL DO
+
+ ! +-- 2. Mise a Jour Variables Historiques (Cas non dendritique)
+ ! + Update of the historical Variables
+ ! + =======================================================
+
+ if(vector) then
+ !XF
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ SphrOK = max(zero, sign(unun, G1snSV(ikl, isn)))
+ H1a_OK = max(zero, sign(unun, vsphe4 - G1snSV(ikl, isn)))
+ H1b_OK = 1 - min(1, istoSV(ikl, isn))
+ H1__OK = H1a_OK * H1b_OK
+ H23aOK = max(zero, sign(unun, vsphe4 - G1_dSV &
+ + G1snSV(ikl, isn)))
+ H23bOK = max(zero, sign(unun, etaSno(ikl, isn) &
+ / max(epsi, dzsnSV(ikl, isn)) &
+ - vtelv1))
+ H23_OK = H23aOK * H23bOK
+ H2__OK = 1 - min(1, istoSV(ikl, isn))
+ H3__OK = 1 - min(1, abs(istoSV(ikl, isn) - istdSV(1)))
+ H45_OK = max(zero, sign(unun, TfSnow - TsisSV(ikl, isn) + epsi))
+ H4__OK = 1 - min(1, abs(istoSV(ikl, isn) - istdSV(2)))
+ H5__OK = 1 - min(1, abs(istoSV(ikl, isn) - istdSV(3)))
+
+ HISupd = &
+ SphrOK * (H1__OK * istdSV(1) &
+ + (1.-H1__OK) * H23_OK * (H2__OK * istdSV(2) &
+ + H3__OK * istdSV(3)) &
+ + (1.-H1__OK) * (1.-H23_OK) * H45_OK * (H4__OK * istdSV(4) &
+ + H5__OK * istdSV(5)))
+ istoSV(ikl, isn) = HISupd + &
+ (1.-min(unun, HISupd)) * istoSV(ikl, isn)
+ enddo
+ enddo
+ else
+
+ ! +-- 2. Mise a Jour Variables Historiques (Cas non dendritique)
+ ! + Update of the historical Variables
+ ! + =======================================================
+
+ do ikl = 1, klonv
+ do isn = iiceSV(ikl), isnoSV(ikl)
+ if(G1snSV(ikl, isn) >= 0.) then
+ if(G1snSV(ikl, isn) < vsphe4 .and. istoSV(ikl, isn) == 0) then
+ istoSV(ikl, isn) = istdSV(1)
+ elseif(G1_dSV - G1snSV(ikl, isn) < vsphe4 .and. &
+ etaSno(ikl, isn) / dzsnSV(ikl, isn) > vtelv1) then
+ if(istoSV(ikl, isn) == 0) &
+ istoSV(ikl, isn) = istdSV(2)
+ if(istoSV(ikl, isn) == istdSV(1)) &
+ istoSV(ikl, isn) = istdSV(3)
+ elseif(TsisSV(ikl, isn) < TfSnow) then
+ if(istoSV(ikl, isn) == istdSV(2)) &
+ istoSV(ikl, isn) = istdSV(4)
+ if(istoSV(ikl, isn) == istdSV(3)) &
+ istoSV(ikl, isn) = istdSV(5)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+
+ ! +-- 3. Tassement mecanique /mechanical Settlement
+ ! + ==========================================
+
+ do ikl = 1, klonv
+ SnMass(ikl) = 0.
+ enddo
+ !XF
+ do ikl = 1, klonv
+
+ smb_old = 0.
+ zn_old = 0
+ do isn = 1, isnoSV(ikl)
+ smb_old = smb_old + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ zn_old = zn_old + dzsnSV(ikl, isn)
+ enddo
+
+ do isn = isnoSV(ikl), 1, -1
+ dSnMas = 100.*dzsnSV(ikl, isn) * ro_dry(ikl, isn)
+ SnMass(ikl) = SnMass(ikl) + 0.5 * dSnMas
+ ViscSn = vvisc1 * vvisc2 &
+ * exp(vvisc3 * ro_dry(ikl, isn) &
+ + vvisc4 * abs(TfSnow - TsisSV(ikl, isn))) &
+ * ro_dry(ikl, isn) / rovisc
+
+ ! +-- Changement de Viscosite si Teneur en Eau liquide
+ ! + Change of the Viscosity if liquid Water Content
+ ! + ------------------------------------------------
+
+ OK_Liq = max(zero, sign(unun, etaSno(ikl, isn) - epsi))
+ OK_Ang = max(zero, sign(unun, vgran6 - G1snSV(ikl, isn))) &
+ * (1 - min(1, abs(istoSV(ikl, isn) - istdSV(1))))
+#if(wp)
+ if(G1snSV(ikl, isn) > 0. .and. G1snSV(ikl, isn) < vsphe4 &
+ .and. istoSV(ikl, isn) == 0) &
+ then
+ write(6, *) ikl, isn, ' G1,G2,hist,OK_Ang ', &
+ G1snSV(ikl, isn), G2snSV(ikl, isn), istoSV(ikl, isn), OK_Ang
+ stop "Grains anguleux mal d?finis"
+ endif
+#endif
+ OKxLiq = max(zero, sign(unun, vtelv1 - etaSno(ikl, isn) &
+ / max(epsi, dzsnSV(ikl, isn)))) &
+ * max(0, sign(1, istoSV(ikl, isn) &
+ - istdSV(1)))
+ ViscSn = &
+ ViscSn * (OK_Liq / (vvisc5 + vvisc6 * etaSno(ikl, isn) &
+ / max(epsi, dzsnSV(ikl, isn))) &
+ + (1.-OK_Liq)) &
+ * (OK_Ang * exp(min(ADSdSV, G2snSV(ikl, isn) - vdiam4)) &
+ + (1.-OK_Ang)) &
+ * (OKxLiq * vvisc7 &
+ + (1.-OKxLiq))
+
+ ! +-- Calcul nouvelle Epaisseur / new Thickness
+ ! + -----------------------------------------
+
+ dzsnew = &
+ dzsnSV(ikl, isn) &
+ * max(vdz3, &
+ (unun - dt__SV2 * max(SnMass(ikl) * cos(slopSV(ikl)), unun) &
+ / max(ViscSn, epsi)))
+ rosnew = ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ / max(1e-10, dzsnew)
+ rosmax = 1./((1.-eta_SV(ikl, isn)) / ro_Ice &
+ + eta_SV(ikl, isn) / ro_Wat)
+ rosnew = min(rosnew, rosmax)
+ dzsnew = dzsnSV(ikl, isn) * ro__SV(ikl, isn) &
+ / max(1e-10, rosnew)
+ ro__SV(ikl, isn) = rosnew
+ dzsnSV(ikl, isn) = dzsnew
+ ro_dry(ikl, isn) = ro__SV(ikl, isn) * (1.-eta_SV(ikl, isn)) * 1.e-3
+ ! +... ro_dry: Dry Density (g/cm3)
+ ! +
+ SnMass(ikl) = SnMass(ikl) + dSnMas * 0.5
+ enddo
+
+ smb_new = 0.
+ do isn = 1, isnoSV(ikl)
+ smb_new = smb_new + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ enddo
+
+ isn = 1
+ if(dzsnSV(ikl, isn) > 0 .and. ro__SV(ikl, isn) > 0) then
+ dzsnSV(ikl, isn) = dzsnSV(ikl, isn) + 0.9999 * (smb_old - smb_new) &
+ / ro__SV(ikl, isn)
+ endif
+
+ zn_new = 0
+ do isn = 1, isnoSV(ikl)
+ zn_new = zn_new + dzsnSV(ikl, isn)
+ enddo
+ zn4_SV(ikl) = zn4_SV(ikl) + (zn_new - zn_old)
+
+ enddo
+
+#if(wp)
+ ! OUTPUT/Verification (stdout)
+ ! ============================
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ if(G1snSV(ikl, isn) > 0. .and. G2snSV(ikl, isn) > D__MAX) then
+ write(6, 6600) G1snSV(ikl, isn), G2snSV(ikl, isn), ikl, isn
+6600 format(/, 'WARNING in _GSn: G1,G2 =', 2f9.3, ' (ikl,isn) =', 2i4)
+ D__MAX = G2snSV(ikl, isn)
+ endif
+ if(G2snSV(ikl, isn) < 0.) then
+ write(6, 6601) G1snSV(ikl, isn), G2snSV(ikl, isn), ikl, isn
+6601 format(/, 'ERROR 1 in _GSn: G1,G2 =', 2f9.3, ' (ikl,isn) =', 2i4)
+ STOP
+ endif
+ if(G1snSV(ikl, isn) > G1_dSV + epsi) then
+ write(6, 6602) G1snSV(ikl, isn), G2snSV(ikl, isn), ikl, isn
+6602 format(/, 'ERROR 2 in _GSn: G1,G2 =', 2f9.3, ' (ikl,isn) =', 2i4)
+ STOP
+ endif
+ if(G1snSV(ikl, isn) < 0. .and. &
+ G2snSV(ikl, isn) > G1_dSV + epsi) then
+ write(6, 6603) G1snSV(ikl, isn), G2snSV(ikl, isn), ikl, isn
+6603 format(/, 'ERROR 3 in _GSn: G1,G2 =', 2f9.3, ' (ikl,isn) =', 2i4)
+ STOP
+ endif
+ enddo
+ enddo
+#endif
+ return
+end
diff --git a/MAR/code_mar/sisvat_ini.f90 b/MAR/code_mar/sisvat_ini.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ef4f401766232271827af4e10b6f82f96ce5092e
--- /dev/null
+++ b/MAR/code_mar/sisvat_ini.f90
@@ -0,0 +1,331 @@
+#include "MAR_pp.def"
+subroutine SISVAT_ini
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_ini Sun 19-04-2021 MAR |
+ ! | subroutine SISVAT_ini generates non time dependant SISVAT parameters |
+ ! +------------------------------------------------------------------------+
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: dt__SV : Time Step [s] |
+ ! | ^^^^^ dz_dSV : Layer Thickness [m] |
+ ! | |
+ ! | OUTPUT: RF__SV : Root Fraction in Layer isl [-] |
+ ! | ^^^^^^ rocsSV : Soil Contrib. to (ro c)_s exclud.Water [J/kg/K] |
+ ! | etamSV : Soil Minimum Humidity [m3/m3] |
+ ! | (based on a prescribed Soil Relative Humidity) |
+ ! | s1__SV : Factor of eta**( b+2) in Hydraul.Diffusiv. |
+ ! | s2__SV : Factor of eta**( b+2) in Hydraul.Conduct. |
+ ! | aKdtSV : KHyd: Piecewise Linear Profile: a * dt [m] |
+ ! | bKdtSV : KHyd: Piecewise Linear Profile: b * dt [m/s] |
+ ! | dzsnSV(0): Soil first Layer Thickness [m] |
+ ! | dzmiSV : Distance between two contiguous levels [m] |
+ ! | dz78SV : 7/8 (Layer Thickness) [m] |
+ ! | dz34SV : 3/4 (Layer Thickness) [m] |
+ ! | dz_8SV : 1/8 (Layer Thickness) [m] |
+ ! | dzAvSV : 1/8 dz_(i-1) + 3/4 dz_(i) + 1/8 dz_(i+1) [m] |
+ ! | dtz_SV : dt/dz [s/m] |
+ ! | OcndSV : Swab Ocean / Soil Ratio [-] |
+ ! | Implic : Implicit Parameter (0.5: Crank-Nicholson) |
+ ! | Explic : Explicit Parameter = 1.0 - Implic |
+ ! | |
+ ! | # OPTIONS: #ER: Richards Equation is not smoothed |
+ ! | # ^^^^^^^ #kd: De Ridder Discretization |
+ ! | # #SH: Hapex-Sahel Values |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use mardim
+ use marphy
+ use mar_sv
+ use mar_tv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use margrd
+ use marctr
+
+ implicit none
+
+ ! +--Internal Variables
+ ! + ==================
+
+ integer i, j, k, ivt, ist, kk, ikl, isl, isn, ikh
+ integer misl_2, nisl_2
+ real zDepth
+ real d__eta, eta__1, eta__2, Khyd_1, Khyd_2
+ real RHsMin ! Min.Soil Relative Humidity
+ real PsiMax ! Max.Soil Water Potential
+ real a_Khyd, b_Khyd ! Piecewis.Water Conductivity
+#if(WR)
+ real Khyd_x, Khyd_y
+#endif
+
+ ! +--DATA
+ ! + ====
+
+ data RHsMin/0.001/ ! Min.Soil Relative Humidity
+
+ ! +--Non Time Dependant SISVAT parameters
+ ! + ====================================
+
+ ! +--Soil Discretization
+ ! + -------------------
+
+ ! +--Numerical Scheme Parameters
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Implic = 0.75 ! 0.5 <==> Crank-Nicholson
+ Explic = 1.00 - Implic !
+
+ ! +--Soil/Snow Layers Indices
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^
+ do isl = -nsol, 0
+ islpSV(isl) = isl + 1
+ islpSV(isl) = min(islpSV(isl), 0)
+ islmSV(isl) = isl - 1
+ islmSV(isl) = max(-nsol, islmSV(isl))
+ enddo
+
+ do isn = 1, nsno
+ isnpSV(isn) = isn + 1
+ isnpSV(isn) = min(isnpSV(isn), nsno)
+ enddo
+#if(kd)
+ ! +--Soil Layers Thicknesses
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ if(nsol > 4) then
+ do isl = -5, -nsol, -1
+ dz_dSV(isl) = 1.
+ enddo
+ endif
+#endif
+
+ dz_dSV(-4:0) = (/0.72, 0.20, 0.060, 0.019, 0.001/)
+
+ if(nsol /= 4) then
+ do isl = 0, -nsol, -1
+ misl_2 = -mod(isl, 2)
+ nisl_2 = -isl / 2
+ dz_dSV(isl) = (((1 - misl_2) * 0.001 &
+ + misl_2 * 0.003) * 10**(nisl_2)) * 4.
+ ! +... dz_dSV(0) = Hapex-Sahel Calibration: 4 mm
+
+ enddo
+ dz_dSV(0) = 0.001
+ dz_dSV(-1) = dz_dSV(-1) - dz_dSV(0) + 0.004
+ endif
+
+ zz_dSV = 0.
+ do isl = -nsol, 0
+ dzmiSV(isl) = 0.500 * (dz_dSV(isl) + dz_dSV(islmSV(isl)))
+ dziiSV(isl) = 0.500 * dz_dSV(isl) / dzmiSV(isl)
+ dzi_SV(isl) = 0.500 * dz_dSV(islmSV(isl)) / dzmiSV(isl)
+ dtz_SV(isl) = dt__SV / dz_dSV(isl)
+ dtz_SV2(isl) = 1./dz_dSV(isl)
+ dz78SV(isl) = 0.875 * dz_dSV(isl)
+ dz34SV(isl) = 0.750 * dz_dSV(isl)
+ dz_8SV(isl) = 0.125 * dz_dSV(isl)
+ dzAvSV(isl) = 0.125 * dz_dSV(islmSV(isl)) &
+ + 0.750 * dz_dSV(isl) &
+ + 0.125 * dz_dSV(islpSV(isl))
+#if(ER)
+ dz78SV(isl) = dz_dSV(isl)
+ dz34SV(isl) = dz_dSV(isl)
+ dz_8SV(isl) = 0.
+ dzAvSV(isl) = dz_dSV(isl)
+#endif
+ zz_dSV = zz_dSV + dz_dSV(isl)
+ enddo
+ do ikl = 1, klonv
+ dzsnSV(ikl, 0) = dz_dSV(0)
+ enddo
+
+ ! +--Conversion to a 50 m Swab Ocean Discretization
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ OcndSV = 0.
+ do isl = -nsol, 0
+ OcndSV = OcndSV + dz_dSV(isl)
+ enddo
+ OcndSV = 50./OcndSV
+
+ ! +--Secondary Vegetation Parameters
+ ! + -------------------------------
+#if(SH)
+ ! +--Minimum Stomatal Resistance (Hapex Sahel Data)
+ ! + (Taylor et al. 1997, J.Hydrol 188-189, p.1047)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ivg = 1, 3
+ StodSV(ivg) = 210. ! Millet
+ enddo
+ StodSV(4) = 120. ! Sparse Tiger Bush
+ do ivg = 5, 6
+ StodSV(ivg) = 80. ! Dense Tiger Bush
+ enddo
+ StodSV(7) = 80. ! Low Trees (Fallow)
+ StodSV(10) = 80.
+ ! +--Minimum Stomatal Resistance (Tropical Forest)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ StodSV(8) = 60. ! Medium Trees
+ StodSV(11) = 60.
+ StodSV(9) = 40. ! High Trees
+ StodSV(12) = 40.
+#endif
+ ! +--Root Fraction
+ ! + ^^^^^^^^^^^^^
+ ! + * GENERAL REFERENCE
+ ! + Jackson et al., 1996: A global analysis of root distributions for
+ ! + terrestrial biomes. In Oecologia, 108, 389-411.
+
+ ! + * ROOT PROFILE
+ ! + The cumulative root fraction Y is given by
+ ! + Y = 1 - beta**d with d the depth (in cm),
+ ! + beta a coefficient (vegetation dependent).
+
+ ! + * BETA VALUES (for 11 world biomes)
+ ! + 1 boreal forest 0.943
+ ! + 2 crops 0.961
+ ! + 3 desert 0.975
+ ! + 4 sclerophyllous shrubs 0.964
+ ! + 5 temperate coniferous forest 0.976
+ ! + 6 temperate deciduous forest 0.966
+ ! + 7 temperate grassland 0.943
+ ! + 8 tropical deciduous forest 0.961
+ ! + 9 tropical evergreen forest 0.962
+ ! + 10 tropical grassland savanna 0.972
+ ! + 11 tundra 0.914
+
+ ! + * ADVISED BETA VALUES FOR MAR
+ ! + (see 'block data SISVAT_dat', variable rbtdSV)
+ ! +
+ ! + SVAT veg. type default West Africa
+ ! + 0 barren soil 0.000 0.000
+ ! + 1 crops low 0.961 (2) 0.961 (2)
+ ! + 2 crops medium 0.961 (2) 0.961 (2)
+ ! + 3 crops high 0.961 (2) 0.961 (2)
+ ! + 4 grass low 0.943 (7) 0.943 (7)
+ ! + 5 grass medium 0.943 (7) 0.964 (4)
+ ! + 6 grass high 0.943 (7) 0.972 (10)
+ ! + 7 broadleaf low 0.966 (6) 0.968 (4,10)
+ ! + 8 broadleaf medium 0.966 (6) 0.962 (8,9)
+ ! + 9 broadleaf high 0.966 (6) 0.962 (8,9)
+ ! + 10 needleleaf low 0.976 (5) 0.971 (5,6)
+ ! + 11 needleleaf medium 0.976 (5) 0.976 (5)
+ ! + 12 needleleaf high 0.976 (5) 0.976 (5)
+
+ ! + Numbers between brackets refer to Jackson's biomes. For more details
+ ! + about some choices, see the correspondance between the IGBP and SVAT
+ ! + vegetation classes (i.e. in NESTOR).
+
+ ! + * WARNING
+ ! + Most of the roots are located in the first 2 m of soil. The root
+ ! + fraction per layer depends on the definition of the soil layer
+ ! + thickness. It will get wrong if a thick layer is defined around 2 m
+ ! + deep.
+
+ ! write(*,'(/a)') 'ROOT PROFILES (Jackson, 1996) :'
+
+ do ivt = 0, nvgt
+ zDepth = 0.
+ do isl = 0, -nsol, -1
+ if(ivt /= 0) then
+ RF__SV(ivt, isl) = rbtdSV(ivt)**zDepth * &
+ (1.-rbtdSV(ivt)**(dz_dSV(isl) * 100))
+ zDepth = zDepth + dz_dSV(isl) * 100 !in cm
+ else
+ RF__SV(ivt, isl) = 0.
+ endif
+ enddo
+ ! write(*,'(a,i2,a,i3,a,99f10.5:)') &
+ ! ' RF__SV(', ivt, ',', -nsol, ':0) =', RF__SV(ivt,:)
+ enddo
+ ! write(6,6600)
+ ! 6600 format(&
+ ! ' NOTE: If root fraction is not close to 0 around 2 m deep,', &
+ ! /, ' Then you should redefine the soil layer thicknesses.', &
+ ! /, ' See the code for more details.')
+
+ ! +--Secondary Soil Parameters
+ ! + -------------------------------
+
+ do ist = 0, nsot
+ rocsSV(ist) = (1.0 - etadSV(ist)) * 1.2E+6 ! Soil Contrib. to (ro c)_s
+ ! Factor of (eta)**(b+2) in DR97, Eqn.(3.36)
+ s1__SV(ist) = bCHdSV(ist) &
+ * psidSV(ist) * Ks_dSV(ist) &
+ / (etadSV(ist)**(bCHdSV(ist) + 3.))
+ ! Factor of (eta)**(2b+3) in DR97, Eqn.(3.35)
+ s2__SV(ist) = Ks_dSV(ist) &
+ / (etadSV(ist)**(2.*bCHdSV(ist) + 3.))
+
+ ! +--Soil Minimum Humidity (from a prescribed minimum relative Humidity)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Psimax = -(log(RHsMin)) / 7.2E-5 ! DR97, Eqn 3.15 Inversion
+ etamSV(ist) = etadSV(ist) &
+ * (PsiMax / psidSV(ist))**(-min(10., 1./bCHdSV(ist)))
+ enddo
+ etamSV(12) = 0.
+
+ ! +--Piecewise Hydraulic Conductivity Profiles
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ist = 0, nsot
+
+#if(WR)
+ write(6, 6000)
+6000 format(' Type | etaSat | No | eta__1 | eta__2 |', &
+ ' Khyd_1 | Khyd_x | Khyd_2 | Khyd_y |' &
+ /, ' -----+-----------+----+-----------+-----------+', &
+ '-----------+-----------+-----------+-----------+')
+#endif
+
+ d__eta = etadSV(ist) / nkhy
+ eta__1 = 0.
+ eta__2 = d__eta
+ do ikh = 0, nkhy
+ ! DR97, Eqn.(3.35)
+ Khyd_1 = s2__SV(ist) &
+ * (eta__1**(2.*bCHdSV(ist) + 3.))
+ Khyd_2 = s2__SV(ist) &
+ * (eta__2**(2.*bCHdSV(ist) + 3.))
+
+ a_Khyd = (Khyd_2 - Khyd_1) / d__eta
+ b_Khyd = Khyd_1 - a_Khyd * eta__1
+#if(WR)
+ Khyd_x = a_Khyd * eta__1 + b_Khyd
+ Khyd_y = a_Khyd * eta__2 + b_Khyd
+#endif
+ aKdtSV(ist, ikh) = a_Khyd * dt__SV
+ bKdtSV(ist, ikh) = b_Khyd * dt__SV
+ aKdtSV2(ist, ikh) = a_Khyd * 1.
+ bKdtSV2(ist, ikh) = b_Khyd * 1.
+
+#if(WR)
+ write(6, 6001) ist, etadSV(ist), ikh, eta__1, &
+ eta__2, Khyd_1, Khyd_x, Khyd_2, Khyd_y
+#endif
+6001 format(i5, ' |', e10.2, ' |', i3, ' |', &
+ 6(e10.2, ' |'))
+
+ eta__1 = eta__1 + d__eta
+ eta__2 = eta__2 + d__eta
+ enddo
+ enddo
+
+ if(itexpe <= 2) then
+ do j = 1, my
+ do i = 1, mx
+ do k = 1, nvx
+ do kk = 1, llx
+ if(TsolTV(i, j, k, kk) <= 273.15) then
+ Eta_TV(i, j, k, kk) = min(Eta_TV(i, j, k, kk), 0.2 * etadSV(isolTV(i, j)))
+ else
+ Eta_TV(i, j, k, kk) = max(Eta_TV(i, j, k, kk), &
+ min(0.7, 0.4 + (TsolTV(i, j, k, kk) - 273.15) / 100.) * etadSV(isolTV(i, j)))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ return
+end
diff --git a/MAR/code_mar/sisvat_qsn.f90 b/MAR/code_mar/sisvat_qsn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bc83687a5e238553ed458b89eb78a6edbb3355e1
--- /dev/null
+++ b/MAR/code_mar/sisvat_qsn.f90
@@ -0,0 +1,856 @@
+#include "MAR_pp.def"
+subroutine SISVAT_qSn()
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_qSn 20-11-2022 MAR |
+ ! | subroutine SISVAT_qSn updates the Snow Water Content |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: isnoSV = total Nb of Ice/Snow Layers |
+ ! | ^^^^^ |
+ ! | |
+ ! | INPUT: TaT_SV : SBL Top Temperature [K] |
+ ! | ^^^^^ dt__SV : Time Step [s] |
+ ! | |
+ ! | INPUT / drr_SV : Rain Intensity [kg/m2/s] |
+ ! | OUTPUT: dzsnSV : Snow Layer Thickness [m] |
+ ! | ^^^^^^ eta_SV : Snow Water Content [m3/m3] |
+ ! | ro__SV : Snow/Soil Volumic Mass [kg/m3] |
+ ! | TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+ ! | & Snow Temperatures (layers 1,2,...,nsno) [K] |
+ ! | |
+ ! | OUTPUT: SWS_SV : Surficial Water Status |
+ ! | ^^^^^^ |
+ ! | EExcsv : Snow Energy in Excess, initial Forcing [J/m2] |
+ ! | EqSn_d : Snow Energy in Excess, remaining [J/m2] |
+ ! | EqSn_0 : Snow Energy, before Phase Change [J/m2] |
+ ! | EqSn_1 : Snow Energy, after Phase Change [J/m2] |
+ ! | SIsubl : Snow sublimed/deposed Mass [mm w.e.] |
+ ! | SImelt : Snow Melted Mass [mm w.e.] |
+ ! | SIrnof : Surficial Water + Run OFF Change [mm w.e.] |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | |
+ ! | # OPTIONS: #E0: IO for Verification: Energy Budget |
+ ! | # ^^^^^^^ |
+ ! | # #su: IO for Verification: Slush Diagnostic |
+ ! | |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SISVAT_qSn.vm | #vm: OUTPUT/Verification: Energy/Water Budget |
+ ! | | unit 43, subroutine SISVAT_qSn **ONLY** |
+ ! | # SISVAT_qSn.vu | #vu: OUTPUT/Verification: Slush Parameteriz. |
+ ! | | unit 44, subroutine SISVAT_qSn **ONLY** |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use marysv
+
+ implicit none
+
+#if(e1)
+ ! Energy Budget
+ ! ~~~~~~~~~~~~~
+ ! EqSn_d : Energy in Excess, initial
+ real EqSn_d(klonv)
+ ! EqSn_0 : Snow Energy, befor Phase Change
+ real EqSn_0(klonv)
+ ! EqSn_1 : Snow Energy, after Phase Change .and. Mass Redistr.
+ real EqSn_1(klonv)
+#endif
+
+#if(vm)
+ ! EqSn01 : Snow Energy, after Phase Change
+ real EqSn01(klonv)
+ ! EqSn02 : Snow Energy, after Phase Change .and. Last Melting
+ real EqSn02(klonv)
+#endif
+ ! Snow/Ice (Mass) Budget
+ ! ~~~~~~~~~~~~~~~~~~~~~~
+#if(m1)
+ ! SIsubl : Snow Deposed Mass
+ real SIsubl(klonv)
+ ! SImelt : Snow Melted Mass
+ real SImelt(klonv)
+ ! SIrnof : Local Surficial Water + Run OFF
+ real SIrnof(klonv)
+#endif
+
+ ! +--Internal Variables
+ ! + ==================
+ integer ikl, isn, flag
+ ! nh : Non erodible Snow: up.lay.Index
+ integer nh
+ ! LayrOK : 1 (0) if In(Above) Snow Pack
+ integer LayrOK
+ ! k_face : 1 (0) if Crystal(no) faceted
+ integer k_face
+ ! LastOK : 1 ==> 1! Snow Layer
+ integer LastOK
+ ! NOLayr : 1 Layer Update
+ integer NOLayr
+ ! noSnow : Nb of Layers Updater
+ integer noSnow(klonv)
+ ! noSnow : Slush Switch
+ integer kSlush
+ ! dTSnow : Temperature[C]
+ real dTSnow
+ ! EExdum : Energy in Excess when no Snow
+ real EExdum(klonv)
+ ! OKmelt : 1 (0) if(no) Melting
+ real OKmelt
+ ! EnMelt : Energy in excess, for Melting
+ real EnMelt
+ ! SnHLat : Energy consumed in Melting
+ real SnHLat
+ ! AdEnrg, B_Enrg : Additional Energy from Vapor
+ real AdEnrg, B_Enrg
+ ! Vaporized Thickness [m]
+ real dzVap0, dzVap1
+ ! Melted Thickness [m]
+ real dzMelt(klonv)
+ ! rosDry : Snow volumic Mass if no Water in
+ real rosDry
+ ! PorVol : Pore volume
+ real PorVol
+ ! PClose : Pore Hole Close OFF Switch
+ real PClose
+ ! SGDiam : Snow Grain Diameter
+ real SGDiam
+ ! SGDmax : Max. Snow Grain Diameter
+ real SGDmax
+ ! rWater : Retained Water [kg/m2]
+ real rWater
+ ! drrNEW : New available Water [kg/m2]
+ real drrNEW
+ ! rdzNEW : Snow Mass [kg/m2]
+ real rdzNEW
+ ! rdzsno : Snow Mass [kg/m2]
+ real rdzsno
+ ! EnFrez : Energy Release in Freezing
+ real EnFrez
+ ! WaFrez : Water consumed in Melting
+ real WaFrez
+ ! RapdOK : 1. ==> Snow melts rapidly
+ real RapdOK
+ ! ThinOK : 1. ==> Snow Layer is thin
+ real ThinOK
+ ! dzepsi : Minim. Snow Layer Thickness (!)
+ real dzepsi
+ ! dz_Min : Minim. Snow Layer Thickness
+ real dz_Min
+ ! z_Melt : Last (thin) Layer Melting
+ real z_Melt
+ ! rusnew : Surficial Water Thickness [mm]
+ real rusnew
+ ! zWater : Max Slush Water Thickness [mm]
+ real zWater
+ ! zSlush : Slush Water Thickness [mm]
+ real zSlush
+ ! ro_new : New Snow/ice Density [kg/m3]
+ real ro_new
+ ! zc, zt : Non erod.Snow Thickness [mm w.e.]
+ real zc, zt
+ ! dru : Surficial Water [kg/m2]
+ real dru
+ real rusnSV0(klonv), sum1(klonv), sum2(klonv)
+ real drr1(klonv), drr2(klonv)
+
+ ! +--OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer isnnew, isinew, isnUpD, isnitr
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+ common / SISVAT_EV / iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+#endif
+#if(vm)
+ ! +--Energy and Mass Budget
+ ! + ~~~~~~~~~~~~~~~~~~~~~~
+ ! WqSn_0 : Snow Water+Forcing Initial
+ real WqSn_0(klonv)
+ ! WqSn_1 : Snow Water+Forcing, Final
+ real WqSn_1(klonv)
+ ! emopen : IO Switch
+ logical emopen
+ common / Se_qSn_L / emopen
+ integer no_err
+ common / Se_qSn_I / no_err
+ real hourer, timeer
+ common / Se_qSn_R / timeer
+#endif
+#if(vu)
+ ! +--Slush Diagnostic: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ ! su_opn : IO Switch
+ logical su_opn
+ common / SI_qSn_L / su_opn
+#endif
+
+ ! +--DATA
+ ! + ====
+ ! dzepsi : Minim. Snow Layer Thickness (!)
+ data dzepsi/0.0001/
+ ! dzepsi = 0.005 : Warning: Too high for Col de Porte: precludes 1st snow (layer) apparition
+ ! data dz_Min/0.005/
+ ! dz_Min : Minim. Snow Layer Thickness
+ data dz_Min/2.5e-3/
+ ! SGDmax : Maxim. Snow Grain Diameter [m] (Rowe et al. 1995, JGR p.16268)
+ data SGDmax/0.003/
+
+#if(e1)
+ ! +--Energy Budget (IN)
+ ! + ==================
+ do ikl = 1, klonv
+ EqSn_0(ikl) = 0.
+ enddo
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ EqSn_0(ikl) = EqSn_0(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ * (Cn_dSV * (TsisSV(ikl, isn) - TfSnow) &
+ - Lf_H2O * (1.-eta_SV(ikl, isn)))
+ enddo
+ enddo
+#endif
+
+#if(vm)
+ ! +--Water Budget (IN)
+ ! + ==================
+ do ikl = 1, klonv
+ WqSn_0(ikl) = drr_SV(ikl) * dt__SV &
+ + rusnSV(ikl)
+ enddo
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ WqSn_0(ikl) = WqSn_0(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn)
+ enddo
+ enddo
+#endif
+
+#if(m1)
+ ! +--Snow Melt Budget
+ ! + ================
+ do ikl = 1, klonv
+ SImelt(ikl) = 0.
+ SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV
+ enddo
+#endif
+
+ ! +--Initialization
+ ! + ==============
+
+ do ikl = 1, klonv
+ ! noSnow : Nb of Layers Updater
+ noSnow(ikl) = 0
+ ! ispiSV : Pore Hole Close OFF Index
+ ! (assumed to be the Top of the surimposed Ice Layer)
+ ispiSV(ikl) = 0
+ zn5_SV(ikl) = 0.
+ rusnSV0(ikl) = 0.
+ sum1(ikl) = 0
+ sum2(ikl) = 0
+ do isn = 1, isnoSV(ikl)
+ sum1(ikl) = sum1(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ enddo
+ drr1(ikl) = drr_SV(ikl) * dt__SV
+ enddo
+
+ ! +--Melting/Freezing Energy
+ ! + =======================
+
+ ! +...REMARK: Snow liquid Water Temperature assumed = TfSnow
+ ! + ^^^^^^
+ do ikl = 1, klonv
+ EExdum(ikl) = drr_SV(ikl) * C__Wat * (TaT_SV(ikl) - TfSnow) &
+ * dt__SV
+ EExcsv(ikl) = EExdum(ikl) * min(1, isnoSV(ikl)) ! Snow exists
+ EExdum(ikl) = EExdum(ikl) - EExcsv(ikl) !
+#if(e1)
+ EqSn_d(ikl) = EExcsv(ikl)
+#endif
+ enddo
+
+ ! +--Surficial Water Status
+ ! + ----------------------
+
+ do ikl = 1, klonv
+ SWS_SV(ikl) = max(zero, sign(unun, TfSnow &
+ - TsisSV(ikl, isnoSV(ikl))))
+ enddo
+
+ do ikl = 1, klonv
+ zt = 0.
+ do isn = 1, isnoSV(ikl)
+ zt = zt + dzsnSV(ikl, isn)
+ enddo
+ do isn = isnoSV(ikl), 1, -1
+
+ ! +--Energy, store Previous Content
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ dTSnow = TsisSV(ikl, isn) - TfSnow
+ EExcsv(ikl) = EExcsv(ikl) &
+ + ro__SV(ikl, isn) * Cn_dSV * dTSnow &
+ * dzsnSV(ikl, isn)
+ TsisSV(ikl, isn) = TfSnow
+
+ ! +--Water, store Previous Content
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ drr_SV(ikl) = drr_SV(ikl) &
+ + ro__SV(ikl, isn) * eta_SV(ikl, isn) &
+ * dzsnSV(ikl, isn) &
+ / dt__SV
+ ro__SV(ikl, isn) = &
+ ro__SV(ikl, isn) * (1.-eta_SV(ikl, isn))
+ eta_SV(ikl, isn) = 0.
+
+ ! +--Melting if EExcsv > 0
+ ! + ======================
+
+ EnMelt = max(zero, EExcsv(ikl))
+
+ ! +--Energy Consumption
+ ! + ^^^^^^^^^^^^^^^^^^
+ SnHLat = ro__SV(ikl, isn) * Lf_H2O
+ dzMelt(ikl) = EnMelt / max(SnHLat, epsi)
+ noSnow(ikl) = noSnow(ikl) &
+ + max(zero, sign(unun, dzMelt(ikl) &
+ ! 1 if full Melt
+ - dzsnSV(ikl, isn))) &
+ ! 1 in the Pack
+ * min(1, max(0, 1 + isnoSV(ikl) - isn))
+ dzMelt(ikl) = &
+ min(dzsnSV(ikl, isn), dzMelt(ikl))
+ dzsnSV(ikl, isn) = &
+ dzsnSV(ikl, isn) - dzMelt(ikl)
+ zn5_SV(ikl) = zn5_SV(ikl) + dzMelt(ikl)
+ EExcsv(ikl) = EExcsv(ikl) - dzMelt(ikl) * SnHLat
+ wem_SV(ikl) = wem_SV(ikl) - dzMelt(ikl) * ro__SV(ikl, isn)
+
+ ! +--Water Production
+ ! + ^^^^^^^^^^^^^^^^^
+ drr_SV(ikl) = drr_SV(ikl) &
+ + ro__SV(ikl, isn) * dzMelt(ikl) / dt__SV
+#if(m1)
+ SImelt(ikl) = SImelt(ikl) &
+ + ro__SV(ikl, isn) * dzMelt(ikl)
+#endif
+ OKmelt = max(zero, sign(unun, drr_SV(ikl) - epsi))
+
+ ! +--Snow History
+ ! + ^^^^^^^^^^^^
+ ! = 1 if faceted
+ k_face = min(istoSV(ikl, isn), istdSV(1)) &
+ * max(0, 2 - istoSV(ikl, isn))
+ istoSV(ikl, isn) = &
+ (1.-OKmelt) * istoSV(ikl, isn) &
+ + OKmelt * ((1 - k_face) * istdSV(2) &
+ + k_face * istdSV(3))
+
+ ! +--Freezing if EExcsv < 0
+ ! + ======================
+ flag = 0
+ if(SWS_SV(ikl) == 0 .and. drr_SV(ikl) == 0 .and. isn == isnoSV(ikl) .and. &
+ ro__SV(ikl, isn) > roCdSV .and. rusnSV(ikl) > 0) flag = 1
+ if(flag == 1) then
+ drr_SV(ikl) = rusnSV(ikl) / dt__SV
+ dru = rusnSV(ikl)
+ endif
+ rdzsno = ro__SV(ikl, isn) * dzsnSV(ikl, isn)
+ LayrOK = min(1, max(0, isnoSV(ikl) - isn + 1))
+ EnFrez = min(zero, EExcsv(ikl))
+ WaFrez = -(EnFrez * LayrOK / Lf_H2O)
+ drrNEW = max(zero, drr_SV(ikl) - WaFrez / dt__SV)
+ WaFrez = (drr_SV(ikl) - drrNEW) * dt__SV
+ drr_SV(ikl) = drrNEW
+ EExcsv(ikl) = EExcsv(ikl) + WaFrez * Lf_H2O
+ EnFrez = min(zero, EExcsv(ikl)) * LayrOK
+ rdzNEW = WaFrez + rdzsno
+ ro__SV(ikl, isn) = rdzNEW / max(epsi, dzsnSV(ikl, isn))
+ TsisSV(ikl, isn) = TfSnow &
+ + EnFrez / (Cn_dSV * max(epsi, rdzNEW))
+ EExcsv(ikl) = EExcsv(ikl) - EnFrez
+ wer_SV(ikl) = WaFrez + wer_SV(ikl)
+ if(flag == 1) then
+ rusnSV(ikl) = drr_SV(ikl) * dt__SV
+ dru = dru - rusnSV(ikl)
+ drr1(ikl) = drr1(ikl) + dru / dt__SV
+ RuofSV(ikl, 2) = max(0., RuofSV(ikl, 2) - dru / dt__SV)
+ drr_SV(ikl) = 0.
+ endif
+
+ ! +--Snow Water Content
+ ! + ==================
+
+ ! +--Percolation Velocity
+ ! + ^^^^^^^^^^^^^^^^^^^^
+#if(PW)
+ SGDiam = 1.6d-4 &
+ + 1.1d-13 * (ro__SV(ikl, isn) * ro__SV(ikl, isn) &
+ * ro__SV(ikl, isn) * ro__SV(ikl, isn))
+#endif
+
+ ! +--Pore Volume [-]
+ ! + ^^^^^^^^^^^^^^^^^
+ rosDry = (1.-eta_SV(ikl, isn)) * ro__SV(ikl, isn) !
+ PorVol = 1.-rosDry / ro_Ice !
+ PorVol = max(PorVol, zero) !
+
+ ! +--Water Retention
+ ! + ^^^^^^^^^^^^^^^^
+ rWater = ws0dSV * PorVol * ro_Wat * dzsnSV(ikl, isn)
+ drrNEW = max(zero, drr_SV(ikl) - rWater / dt__SV)
+ rWater = (drr_SV(ikl) - drrNEW) * dt__SV
+ drr_SV(ikl) = drrNEW
+ rdzNEW = rWater &
+ + rosDry * dzsnSV(ikl, isn)
+ eta_SV(ikl, isn) = rWater / max(epsi, rdzNEW)
+ ro__SV(ikl, isn) = rdzNEW / max(epsi, dzsnSV(ikl, isn))
+
+ ! +--Pore Hole Close OFF
+ ! + ^^^^^^^^^^^^^^^^^^^
+ PClose = max(zero, &
+ sign(unun, ro__SV(ikl, isn) &
+ - roCdSV))
+ ! Water under SuPer.Ice contributes to Surficial Water
+ ispiSV(ikl) = ispiSV(ikl) * (1.-PClose) &
+ + max(ispiSV(ikl), isn) * Pclose
+ ! PClose = max(0, min (1, ispiSV(ikl) - isn))
+ PClose = 1.-(ro_ice - ro__SV(ikl, isn)) / (ro_ice - roCdSV)
+ PClose = max(0., min(1., PClose))
+
+ if(ro__SV(ikl, isn) > 900) then
+ dzsnSV(ikl, isn) = dzsnSV(ikl, isn) * ro__SV(ikl, isn) / ro_ice
+ ro__SV(ikl, isn) = ro_ice
+ PClose = 1
+ ! eta_SV(ikl, isn) = 0
+ endif
+
+ if(isnoSV(ikl) >= 3 .and. &
+ ro__SV(ikl, isn) >= roCdSV .and. &
+ (ro__SV(ikl, 1) * dzsnSV(ikl, 1) + &
+ ro__SV(ikl, 2) * dzsnSV(ikl, 2)) / &
+ (dzsnSV(ikl, 1) + dzsnSV(ikl, 2)) < 900) &
+ PClose = PClose / 3. ! ice lense
+#if(EU)
+ zt = 1.
+#endif
+ if(isn == 1 .and. zt > 15) then
+ ! > 15 meter of snwow => ice sheet
+ PClose = 1
+ ispiSV(ikl) = max(ispiSV(ikl), 1)
+ endif
+
+ if(isnoSV(ikl) == 0) PClose = 0.
+ rusnSV(ikl) = rusnSV(ikl) &
+ + drr_SV(ikl) * dt__SV * PClose
+ rusnSV0(ikl) = rusnSV0(ikl) &
+ + drr_SV(ikl) * dt__SV * PClose
+ drr_SV(ikl) = drr_SV(ikl) * (1.-PClose)
+
+ enddo
+ enddo
+
+ ! +--Remove Zero-Thickness Layers
+ ! + ============================
+
+1000 continue
+ isnitr = 0
+ do ikl = 1, klonv
+ isnUpD = 0
+ isinew = 0
+ !XF
+ do isn = 1, min(nsno - 1, isnoSV(ikl))
+ isnnew = (unun - max(zero, sign(unun, dzsnSV(ikl, isn) - dzepsi))) &
+ * max(0, min(1, isnoSV(ikl) + 1 - isn))
+ isnUpD = max(isnUpD, isnnew)
+ isnitr = max(isnitr, isnnew)
+ ! LowerMost 0-Layer
+ isinew = isn * isnUpD * max(0, 1 - isinew) &
+ + isinew ! Index
+ dzsnSV(ikl, isn) = dzsnSV(ikl, isn + isnnew)
+ ro__SV(ikl, isn) = ro__SV(ikl, isn + isnnew)
+ TsisSV(ikl, isn) = TsisSV(ikl, isn + isnnew)
+ eta_SV(ikl, isn) = eta_SV(ikl, isn + isnnew)
+ G1snSV(ikl, isn) = G1snSV(ikl, isn + isnnew)
+ G2snSV(ikl, isn) = G2snSV(ikl, isn + isnnew)
+ dzsnSV(ikl, isn + isnnew) = (1 - isnnew) * dzsnSV(ikl, isn + isnnew)
+ ro__SV(ikl, isn + isnnew) = (1 - isnnew) * ro__SV(ikl, isn + isnnew)
+ eta_SV(ikl, isn + isnnew) = (1 - isnnew) * eta_SV(ikl, isn + isnnew)
+ G1snSV(ikl, isn + isnnew) = (1 - isnnew) * G1snSV(ikl, isn + isnnew)
+ G2snSV(ikl, isn + isnnew) = (1 - isnnew) * G2snSV(ikl, isn + isnnew)
+ enddo
+ isnoSV(ikl) = isnoSV(ikl) - isnUpD ! Nb of Snow Layer
+ ! Nb of SuperI Layer
+ ispiSV(ikl) = ispiSV(ikl) &
+ ! Update if I=0
+ - isnUpD * max(0, min(ispiSV(ikl) - isinew, 1))
+
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(wx)
+ if(isnUpD > 0 .and. ikl == kSV_v1 .and. lSV_v1 == 3) &
+ write(6, *) ' MERGE ', isnoSV(ikl), ' Grid ', iSV_v1, jSV_v1, nSV_v1
+#endif
+
+ enddo
+ if(isnitr > 0) go to 1000
+
+ ! +--New upper Limit of the non erodible Snow (istoSV .GT. 1)
+ ! + ========================================
+
+ do ikl = 1, klonv
+ nh = 0
+ !XF
+ do isn = isnoSV(ikl), 1, -1
+ nh = nh + isn * min(istoSV(ikl, isn) - 1, 1) * max(0, 1 - nh)
+ enddo
+ zc = 0.
+ zt = 0.
+ !XF
+ do isn = 1, isnoSV(ikl)
+ zc = zc + dzsnSV(ikl, isn) * ro__SV(ikl, isn) &
+ * max(0, min(1, nh + 1 - isn))
+ zt = zt + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ enddo
+ zWE_SV(ikl) = zt
+ zWEcSV(ikl) = min(zWEcSV(ikl), zt)
+ zWEcSV(ikl) = max(zWEcSV(ikl), zc)
+ enddo
+
+ ! +--Energy Budget (OUT)
+ ! + ===================
+
+#if(vm)
+ do ikl = 1, klonv
+ EqSn01(ikl) = -EqSn_0(ikl) &
+ - EExcsv(ikl)
+ enddo
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ EqSn01(ikl) = EqSn01(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ * (Cn_dSV * (TsisSV(ikl, isn) - TfSnow) &
+ - Lf_H2O * (1.-eta_SV(ikl, isn)))
+ enddo
+ enddo
+#endif
+
+ ! +--"Negative Heat" from supercooled rain
+ ! + ------------------------------------
+
+ do ikl = 1, klonv
+ EExcsv(ikl) = EExcsv(ikl) + EExdum(ikl)
+
+ ! +--Surficial Water Run OFF
+ ! + -----------------------
+
+ rusnew = rusnSV(ikl) * SWf_SV(ikl)
+
+ if(isnoSV(ikl) <= 1) rusnew = 0.
+ if(ivgtSV(ikl) >= 1) rusnew = 0.
+
+#if(EU)
+ rusnew = 0.
+#endif
+#if(AC)
+ rusnew = 0.
+#endif
+ RnofSV(ikl) = RnofSV(ikl) + (rusnSV(ikl) - rusnew) / dt__SV
+ RuofSV(ikl, 2) = RuofSV(ikl, 2) + (rusnSV0(ikl)) / dt__SV
+ rusnSV(ikl) = rusnew
+ enddo
+
+ ! +--Percolation down the Continental Ice Pack
+ ! + -----------------------------------------
+
+ ! do ikl = 1, klonv
+ ! drr_SV(ikl) = drr_SV(ikl) + &
+ ! rusnSV(ikl) * (1 - min(1, ispiSV(ikl))) / dt__SV
+ ! rusnSV(ikl) = rusnSV(ikl) * min(1, ispiSV(ikl))
+ ! end do
+
+ !XF removal of too thin snowlayers if TT> 275.15 + bug if TT>> 273.15
+ do ikl = 1, klonv
+ zt = 0.
+ do isn = 1, isnoSV(ikl)
+ zt = zt + dzsnSV(ikl, isn)
+ enddo
+ if(zt < 0.005 + (TaT_SV(ikl) - 275.15) / 1000. .and. &
+ isnoSV(ikl) > 0 .and. &
+ TaT_SV(ikl) >= 275.15 .and. &
+ istoSV(ikl, isnoSV(ikl)) > 1) then
+ do isn = 1, isnoSV(ikl)
+ drr_SV(ikl) = drr_SV(ikl) &
+ + dzsnSV(ikl, isn) * ro__SV(ikl, isn) / dt__SV
+ dzsnSV(ikl, isn) = 0.
+ enddo
+ isnoSV(ikl) = 0
+ endif
+ enddo
+
+ ! +--Slush Formation (CAUTION: ADD RunOff Possibility before Activation)
+ ! + --------------- ^^^^^^^ ^^^
+
+#if(vu)
+ if(.not. su_opn) then
+ su_opn = .true.
+ open(unit=44, status='unknown', file='SISVAT_qSn.vu')
+ rewind 44
+ endif
+ write(44, 440) daHost
+440 format('iSupI i dz ro eta', &
+ ' PorVol zSlush ro_n eta_n', 2x, a18)
+#endif
+
+ ! #if(SU)
+ ! do ikl = 1, klonv
+ ! do isn = 1, isnoSV(ikl)
+ ! kSlush = min(1, max(0, isn + 1 - ispiSV(ikl))) ! Slush Switch
+ ! ! +--Available Additional Pore Volume [-]
+ ! ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! ! [--]
+ ! PorVol = 1. - ro__SV(ikl, isn) &
+ ! * (1. - eta_SV(ikl, isn)) / ro_Ice &
+ ! - eta_SV(ikl, isn) &
+ ! * ro__SV(ikl, isn) / ro_Wat
+ ! PorVol = max(PorVol, zero)
+ ! ! [mm] OR [kg/m2]
+ ! ! 0 <=> freezing
+ ! ! 1 <=> isn=isnoSV
+ ! zWater = dzsnSV(ikl, isn) * PorVol * 1000. &
+ ! * (1. - SWS_SV(ikl) &
+ ! * (1 - min(1, iabs(isn - isnoSV(ikl)))))
+ ! ! [mm] OR [kg/m2]
+ ! zSlush = min(rusnSV(ikl), zWater)
+ ! ro_new = (dzsnSV(ikl, isn) * ro__SV(ikl, isn) &
+ ! + zSlush) &
+ ! / max(dzsnSV(ikl, isn), epsi)
+ ! if(ro_new<ro_Ice + 20) then ! MAX 940kg/m3
+ ! ! [mm] OR [kg/m2]
+ ! rusnSV(ikl) = rusnSV(ikl) - zSlush
+ ! rusnSV0(ikl) = rusnSV0(ikl) - zSlush
+ ! RuofSV(ikl, 2) = max(0., RuofSV(ikl, 2) - zSlush / dt__SV)
+ ! eta_SV(ikl, isn) = (ro_new - ro__SV(ikl, isn) &
+ ! * (1. - eta_SV(ikl, isn))) &
+ ! / max (ro_new, epsi)
+ ! ro__SV(ikl, isn) = ro_new
+ ! end if
+ ! end do
+ ! end do
+ ! #endif
+
+ ! +--Mass conservation
+ ! + =================
+ do ikl = 1, klonv
+ RuofSV(ikl, 3) = RuofSV(ikl, 3) + drr_SV(ikl)
+ drr2(ikl) = drr_SV(ikl) * dt__SV + rusnSV0(ikl)
+ do isn = 1, isnoSV(ikl)
+ sum2(ikl) = sum2(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+ enddo
+ sum1(ikl) = sum1(ikl) + (drr1(ikl) - drr2(ikl))
+ isn = 1
+ if(isnoSV(ikl) > 1) then
+ dzsnSV(ikl, isn) = dzsnSV(ikl, isn) + (sum1(ikl) - sum2(ikl)) / ro__SV(ikl, isn)
+ endif
+ enddo
+
+ ! +--Impact of the Sublimation/Deposition on the Surface Mass Balance
+ ! + ================================================================
+
+ do ikl = 1, klonv
+ isn = isnoSV(ikl)
+ dzVap0 = dt__SV * HLs_sv(ikl) * min(isn, 1) &
+ / (Lx_H2O(ikl) * max(ro__SV(ikl, isn), epsi))
+ NOLayr = min(zero, sign(unun, dzsnSV(ikl, isn) + dzVap0))
+ dzVap1 = min(zero, dzsnSV(ikl, isn) + dzVap0)
+
+ ! +--Additional Energy
+ ! + -----------------
+
+#if(VH)
+ ! Water Vapor Sensible Heat
+ AdEnrg = dzVap0 * ro__SV(ikl, isnoSV(ikl)) &
+ * C__Wat * (TsisSV(ikl, isnoSV(ikl)) - TfSnow)
+#endif
+
+#if(aH)
+ B_Enrg = (Cn_dSV * (TsisSV(ikl, isn) - TfSnow) &
+ - Lf_H2O * (1.-eta_SV(ikl, isn))) &
+ / (1.+dzVap0 / max(epsi, dzsnSV(ikl, isn)))
+ eta_SV(ikl, isn) = &
+ max(zero, unun + (B_Enrg &
+ - (TsisSV(ikl, isn) - TfSnow) * Cn_dSV) &
+ / Lf_H2O)
+ TsisSV(ikl, isn) = (B_Enrg &
+ + (1.-eta_SV(ikl, isn)) &
+ * Lf_H2O) &
+ / Cn_dSV &
+ + TfSnow
+#endif
+
+#if(e1)
+ STOP "PLEASE add Energy (#aH) from deposition/sublimation"
+#endif
+ ! +--Update of the upper Snow layer Thickness
+ ! + ----------------------------------------
+ dzsnSV(ikl, isn) = max(zero, dzsnSV(ikl, isnoSV(ikl)) + dzVap0)
+ isnoSV(ikl) = isnoSV(ikl) + NOLayr
+ isn = isnoSV(ikl)
+ dzsnSV(ikl, isn) = dzsnSV(ikl, isn) + dzVap1
+ wee_SV(ikl, 3) = wee_SV(ikl, 3) - ro__SV(ikl, isn) * dzVap0
+ enddo
+
+#if(vm)
+ ! +--Energy Budget (OUT)
+ ! + ===================
+ do ikl = 1, klonv
+ EqSn02(ikl) = -EqSn_0(ikl) - EExcsv(ikl)
+ enddo
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ EqSn02(ikl) = EqSn01(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ * (Cn_dSV * (TsisSV(ikl, isn) - TfSnow) &
+ - Lf_H2O * (1.-eta_SV(ikl, isn)))
+ enddo
+ enddo
+#endif
+
+#if(m1)
+ ! +--Snow/I Budget
+ ! + -------------
+ do ikl = 1, klonv
+ SIsubl(ikl) = dt__SV * HLs_sv(ikl) * min(isnoSV(ikl), 1) &
+ / Lx_H2O(ikl)
+ SIrnof(ikl) = rusnSV(ikl) + RnofSV(ikl) * dt__SV &
+ - SIrnof(ikl)
+ enddo
+#endif
+
+ ! +--Anticipated Disappearance of a rapidly Melting too thin Last Snow Layer
+ ! + =======================================================================
+ do ikl = 1, klonv
+ LastOK = min(1, max(0, iiceSV(ikl) - isnoSV(ikl) + 2) &
+ * min(1, isnoSV(ikl) - iiceSV(ikl)) &
+ + min(1, isnoSV(ikl)))
+ RapdOK = max(zero, sign(unun, dzMelt(ikl) - epsi))
+ ThinOK = max(zero, sign(unun, dz_Min - dzsnSV(ikl, 1)))
+ z_Melt = LastOK * RapdOK * ThinOK
+ noSnow(ikl) = noSnow(ikl) + z_Melt
+ z_Melt = z_Melt * dzsnSV(ikl, 1)
+ dzsnSV(ikl, 1) = dzsnSV(ikl, 1) - z_Melt
+ EExcsv(ikl) = EExcsv(ikl) - z_Melt * ro__SV(ikl, 1) &
+ * (1.-eta_SV(ikl, 1)) * Lf_H2O
+
+ ! +--Water Production
+ ! + ^^^^^^^^^^^^^^^^^
+ drr_SV(ikl) = drr_SV(ikl) + ro__SV(ikl, 1) * z_Melt / dt__SV
+ enddo
+
+ ! +--Update Nb of Layers
+ ! + ===================
+#if(EF)
+ if(isnoSV(1) > 0) &
+ write(6, 6005) noSnow(1)
+6005 format(i3, ' (noSnow) ')
+#endif
+ do ikl = 1, klonv
+ isnoSV(ikl) = isnoSV(ikl) * min(1, iabs(isnoSV(ikl) - noSnow(ikl)))
+ enddo
+
+#if(e1)
+ ! Energy Budget (OUT)
+ ! ===================
+ do ikl = 1, klonv
+ EqSn_1(ikl) = 0.
+ enddo
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ EqSn_1(ikl) = EqSn_1(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ * (Cn_dSV * (TsisSV(ikl, isn) - TfSnow) &
+ - Lf_H2O * (1.-eta_SV(ikl, isn)))
+ enddo
+ enddo
+#endif
+
+#if(vm)
+ ! +--Water Budget (OUT)
+ ! + ===================
+ do ikl = 1, klonv
+ WqSn_0(ikl) = WqSn_0(ikl) &
+ + HLs_sv(ikl) * dt__SV &
+ * min(isnoSV(ikl), 1) / Lx_H2O(ikl)
+ WqSn_1(ikl) = drr_SV(ikl) * dt__SV &
+ + rusnSV(ikl) &
+ + RnofSV(ikl) * dt__SV
+ enddo
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ WqSn_1(ikl) = WqSn_1(ikl) &
+ + ro__SV(ikl, isn) * dzsnSV(ikl, isn)
+ enddo
+ enddo
+ ! +--OUTPUT Budget
+ ! + =============
+ if(.not. emopen) then
+ emopen = .true.
+ open(unit=43, status='unknown', file='SISVAT_qSn.vm')
+ rewind 43
+ write(43, 43)
+43 format('subroutine SISVAT_qSn: Local Energy and Water Budgets', &
+ /, '=====================================================')
+ endif
+ do ikl = 1, klonv
+ if(EqSn01(ikl) > 1.e-3) write(43, 431) dahost, EqSn01(ikl)
+431 format(' WARNING (1) in _qSn,', a18, &
+ ': Energy Unbalance in Phase Change = ', e15.6)
+ enddo
+ do ikl = 1, klonv
+ if(EqSn02(ikl) > 1.e-3) write(43, 432) dahost, EqSn01(ikl)
+432 format(' WARNING (2) in _qSn,', a18, &
+ ': Energy Unbalance in Phase Change = ', e15.6)
+ enddo
+ timeer = timeer + dt__SV
+ hourer = 3600.0
+ if(mod(no_err, 11) == 0) then
+ no_err = 1
+ write(43, 435) timeer / hourer
+435 format(11('-'), '----------+-', 3('-'), '----------+-', &
+ 3('-'), '----------+-', 3('-'), '----------+-', &
+ '----------------+----------------+', &
+ /, f8.2, 3x, 'EqSn_0(1) | ', 3x, 'EqSn_d(1) | ', &
+ 3x, 'EqSn_1(1) | ', 3x, 'EExcsv(1) | ', &
+ 'E_0+E_d-E_1-EE | Water Budget |', &
+ /, 11('-'), '----------+-', 3('-'), '----------+-', &
+ 3('-'), '----------+-', 3('-'), '----------+-', &
+ '----------------+----------------+')
+ endif
+ if(abs(EqSn_0(1) + EqSn_d(1) - EqSn_1(1) - EExcsv(1)) > epsi .OR. &
+ abs(WqSn_1(1) - WqSn_0(1)) > epsi) then
+ no_err = no_err + 1
+ write(43, 436) EqSn_0(1), EqSn_d(1) &
+ , EqSn_1(1), EExcsv(1) &
+ , EqSn_0(1) + EqSn_d(1) - EqSn_1(1) - EExcsv(1) &
+ , WqSn_1(1) - WqSn_0(1)
+436 format(8x, f12.0, ' + ', f12.0, ' - ', f12.0, ' - ', f12.3, ' = ', f12.3, &
+ ' | ', f15.9)
+ endif
+#endif
+#if(e1)
+ do ikl = 1, klonv
+ EqSn_d(ikl) = EqSn_d(ikl) - EExcsv(ikl)
+ enddo
+#endif
+
+ return
+endsubroutine SISVAT_qSn
diff --git a/MAR/code_mar/sisvat_qso.f90 b/MAR/code_mar/sisvat_qso.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3a97547a6a315dfbbbbf0976bb7db5986e3a16a7
--- /dev/null
+++ b/MAR/code_mar/sisvat_qso.f90
@@ -0,0 +1,862 @@
+#include "MAR_pp.def"
+subroutine SISVAT_qSo(Wats_0, Wats_1, Wats_d)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_qSo 14-03-2022 MAR |
+ ! | subroutine SISVAT_qSo computes the Soil Water Balance |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: isnoSV = total Nb of Ice/Snow Layers |
+ ! | ^^^^^ isotSV = 0,...,11: Soil Type |
+ ! | 0: Water, Solid or Liquid |
+ ! | |
+ ! | INPUT: rhT_SV : SBL Top Air Density [kg/m3] |
+ ! | ^^^^^ drr_SV : Rain Intensity [kg/m2/s] |
+ ! | LSdzsv : Vertical Discretization Factor [-] |
+ ! | = 1. Soil |
+ ! | = 1000. Ocean |
+ ! | dt__SV : Time Step [s] |
+ ! | |
+ ! | Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] |
+ ! | HLs_sv : Latent Heat Flux [W/m2] |
+ ! | Rootsv : Root Water Pump [kg/m2/s] |
+ ! | |
+ ! | INPUT / eta_SV : Water Content [m3/m3] |
+ ! | OUTPUT: Khydsv : Soil Hydraulic Conductivity [m/s] |
+ ! | ^^^^^^ |
+ ! | |
+ ! | OUTPUT: RnofSV : RunOFF Intensity [kg/m2/s] |
+ ! | ^^^^^^ Wats_0 : Soil Water, before Forcing [mm] |
+ ! | Wats_1 : Soil Water, after Forcing [mm] |
+ ! | Wats_d : Soil Water Forcing [mm] |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | z_Bump : (Partly)Bumpy Layers Height [m] |
+ ! | z0Bump : Bumpy Layers Height [m] |
+ ! | dzBump : Lowest Bumpy Layer: [m] |
+ ! | etBump : Bumps Layer Averaged Humidity [m3/m3] |
+ ! | etaMid : Layer Interface's Humidity [m3/m3] |
+ ! | eta__f : Layer Humidity (Water Front)[m3/m3] |
+ ! | Dhyd_f : Soil Hydraulic Diffusivity (Water Front) [m2/s] |
+ ! | Dhydif : Soil Hydraulic Diffusivity [m2/s] |
+ ! | WgFlow : Water gravitational Flux [kg/m2/s] |
+ ! | Wg_MAX : Water MAXIMUM gravitational Flux [kg/m2/s] |
+ ! | SatRat : Water Saturation Flux [kg/m2/s] |
+ ! | WExces : Water Saturation Excess Flux [kg/m2/s] |
+ ! | Dhydtz : Dhydif * dt / dz [m] |
+ ! | FreeDr : Free Drainage Fraction [-] |
+ ! | Elem_A : A Diagonal Coefficient |
+ ! | Elem_C : C Diagonal Coefficient |
+ ! | Diag_A : A Diagonal |
+ ! | Diag_B : B Diagonal |
+ ! | Diag_C : C Diagonal |
+ ! | Term_D : Independant Term |
+ ! | Aux__P : P Auxiliary Variable |
+ ! | Aux__Q : Q Auxiliary Variable |
+ ! | |
+ ! | TUNING PARAMETER: |
+ ! | ^^^^^^^^^^^^^^^^ |
+ ! | z0soil : Soil Surface averaged Bumps Height [m] |
+ ! | |
+ ! | METHOD: NO Skin Surface Humidity |
+ ! | ^^^^^^ Semi-Implicit Crank Nicholson Scheme |
+ ! | (Partial) free Drainage, Water Bodies excepted (Lakes, Sea) |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | # #m0: Water Budget Verification |
+ ! | # #m1: Snow/I Budget Verification |
+ ! | |
+ ! | # OPTIONS: #GF: Saturation Front |
+ ! | # ^^^^^^^ #GH: Saturation Front allows Horton Runoff |
+ ! | # #GA: Soil Humidity Geometric Average |
+ ! | # #BP: Parameterization of Terrain Bumps |
+ ! | |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SISVAT_qSo.vw | #vw: OUTPUT/Verif+Detail: H2O Conservation |
+ ! | | unit 42, subroutine SISVAT_qSo **ONLY** |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use marctr
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--OUTPUT
+ ! + ------
+
+ ! Water (Mass) Budget
+ ! ~~~~~~~~~~~~~~~~~~~
+ real Wats_0(klonv) ! Soil Water, before forcing
+ real Wats_1(klonv) ! Soil Water, after forcing
+ real Wats_d(klonv) ! Soil Water forcing
+
+ ! +--Internal Variables
+ ! + ==================
+
+ integer isl, jsl, ist, ikl
+ integer ikm, ikp, ik0, ik1
+ ! ist__s, ist__w : Soil/Water Body Identifier
+ integer ist__s, ist__w
+#if(BP)
+ ! z0soil : Soil Surface Bumps Height [m]
+ real z0soil
+ data z0soil/0.020/
+ ! z_Bump : (Partly) Bumpy Layers Height [m]
+ real z_Bump
+ ! z0Bump : Bumpy Layers Height [m]
+ real z0Bump
+ ! dzBump : Lowest Bumpy Layer:
+ real dzBump
+ ! etBump : Bumps Layer Averaged Humidity
+ real etBump(klonv)
+#endif
+ ! etaMid : Layer Interface's Humidity
+ real etaMid
+ ! Dhydif : Hydraulic Diffusivity [m2/s]
+ real Dhydif
+ ! eta__f : Water Front Soil Water Content
+ real eta__f
+ ! Khyd_f : Water Front Hydraulic Conduct.
+ real Khyd_f
+ ! Khydav : Hydraulic Conductivity [m/s]
+ real Khydav
+ ! WgFlow : Water gravitat. Flux [kg/m2/s]
+ real WgFlow
+ ! Wg_MAX : Water MAX.grav. Flux [kg/m2/s]
+ real Wg_MAX
+ ! SatRat : Saturation Flux [kg/m2/s]
+ real SatRat
+ ! WExces : Saturat. Excess Flux [kg/m2/s]
+ real WExces
+ ! SoRnOF, SoRnOF2 : Soil Run OFF
+ real SoRnOF(klonv), SoRnOF2(klonv)
+ ! Dhydtz : Dhydif * dt / dz [m]
+ real Dhydtz(klonv, -nsol:0)
+ ! Elem_A, Elem_B, Elem_C : Diagonal Coefficients
+ real Elem_A, Elem_B, Elem_C
+ ! Diag_A : A Diagonal
+ real Diag_A(klonv, -nsol:0)
+ ! Diag_B : B Diagonal
+ real Diag_B(klonv, -nsol:0)
+ ! Diag_C : C Diagonal
+ real Diag_C(klonv, -nsol:0)
+ ! Term_D : Independant Term
+ real Term_D(klonv, -nsol:0)
+ ! Aux__P : P Auxiliary Variable
+ real Aux__P(klonv, -nsol:0)
+ ! Aux__Q : Q Auxiliary Variable
+ real Aux__Q(klonv, -nsol:0)
+ ! etaaux : Soil Water Content [m3/m3]
+ real etaaux(klonv, -nsol:-nsol + 1)
+ ! FreeDr : Free Drainage Fraction (actual)
+ real FreeDr
+ ! FreeD0 : Free Drainage Fraction (1=Full)
+ real FreeD0
+ ! aKdtSV3 : Khyd=a*eta+b: a * dt
+ real aKdtSV3(0:nsot, 0:nkhy)
+ ! bKdtSV3 : Khyd=a*eta+b: b * dt
+ real bKdtSV3(0:nsot, 0:nkhy)
+ real sum1(klonv), sum2(klonv)
+
+#if(mw)
+ ! Water (Mass) Budget
+ ! ~~~~~~~~~~~~~~~~~~~
+ ! mwopen : IO Switch
+ logical mwopen
+ common / Sm_qSo_L / mwopen
+ real hourwr, timewr
+ common / Sm_qSo_R / timewr
+ real Evapor(klonv)
+#endif
+
+ ! +--Internal DATA
+ ! + =============
+ ! FreeD0 : Free Drainage Fraction (1=Full)
+ data FreeD0/1.000/
+
+ aKdtSV3 = aKdtSV2 * dt__SV
+ bKdtSV3 = bKdtSV2 * dt__SV
+#if(m0)
+ ! Water Budget (IN)
+ ! ==================
+ do ikl = 1, klonv
+ ! OLD RunOFF Contrib.
+ Wats_0(ikl) = 0.
+ ! Water Surface Forc.
+ Wats_d(ikl) = drr_SV(ikl)
+ enddo
+ isl = -nsol
+ do ikl = 1, klonv
+ Wats_0(ikl) = Wats_0(ikl) &
+ + ro_Wat * (eta_SV(ikl, isl) * dz78SV(isl) &
+ + eta_SV(ikl, isl + 1) * dz_8SV(isl)) * LSdzsv(ikl)
+ enddo
+ do isl = -nsol + 1, -1
+ do ikl = 1, klonv
+ Wats_0(ikl) = Wats_0(ikl) &
+ + ro_Wat * (eta_SV(ikl, isl) * dz34SV(isl) &
+ + (eta_SV(ikl, isl - 1) &
+ + eta_SV(ikl, isl + 1)) * dz_8SV(isl)) * LSdzsv(ikl)
+ enddo
+ enddo
+ isl = 0
+ do ikl = 1, klonv
+ Wats_0(ikl) = Wats_0(ikl) &
+ + ro_Wat * (eta_SV(ikl, isl) * dz78SV(isl) &
+ + eta_SV(ikl, isl - 1) * dz_8SV(isl)) * LSdzsv(ikl)
+ enddo
+#else
+ Wats_0 = 0.
+ Wats_1 = 0.
+ Wats_d = 0.
+#endif
+
+ ! +--Gravitational Flow
+ ! + ==================
+
+ ! +... METHOD: Surface Water Flux saturates successively the soil layers
+ ! + ^^^^^^ from up to below, but is limited by infiltration capacity.
+ ! + Hydraulic Conductivity again contributes after this step,
+ ! + not redundantly because of a constant (saturated) profile.
+
+ ! +--Flux Limitor
+ ! + ^^^^^^^^^^^^^
+ isl = 0
+ do ikl = 1, klonv
+ ! Soil Type
+ ist = isotSV(ikl)
+ ! 1 => Soil
+ ist__s = min(ist, 1)
+ ! 1 => Water Body
+ ist__w = 1 - ist__s
+ ! Hydraulic Diffusivity DR97, Eqn.(3.36)
+ Dhydif = s1__SV(ist) &
+ * max(epsi, eta_SV(ikl, isl)) &
+ **(bCHdSV(ist) + 2.)
+ ! Water Bodies
+ Dhydif = ist__s * Dhydif &
+ + ist__w * vK_dSV
+ ! DR97 Assumption Water Bodies
+ Khydav = ist__s * Ks_dSV(ist) &
+ + ist__w * vK_dSV
+ ! +
+ ! MAXimum Infiltration Rate
+ Wg_MAX = ro_Wat * Dhydif &
+ * (etadSV(ist) - eta_SV(ikl, isl)) &
+ / (dzAvSV(isl) * LSdzsv(ikl)) &
+ + ro_Wat * Khydav
+
+ ! +--Surface Horton RunOFF
+ ! + ^^^^^^^^^^^^^^^^^^^^^
+ if(ivgtSV(ikl) >= 0 .and. ivgtSV(ikl) <= 6) then ! crop/grass
+ Wg_MAX = max(Wg_MAX, 0.10 * drr_SV(ikl))
+ endif
+
+ if(ivgtSV(ikl) >= 7 .and. ivgtSV(ikl) <= 12) then ! forest
+ Wg_MAX = max(Wg_MAX, 0.05 * drr_SV(ikl))
+ endif
+
+ if(ivgtSV(ikl) == 13) then ! city
+ Wg_MAX = max(Wg_MAX, 0.5 * drr_SV(ikl))
+ endif
+ SoRnOF(ikl) = max(zero, drr_SV(ikl) - Wg_MAX)
+ RuofSV(ikl, 4) = RuofSV(ikl, 4) + SoRnOF(ikl)
+ drr_SV(ikl) = drr_SV(ikl) - SoRnOF(ikl)
+ SoRnOF2(ikl) = 0.
+ enddo
+#if(GF)
+ do isl = 0, -nsol, -1
+ do ikl = 1, klonv
+ ist = isotSV(ikl) ! Soil Type
+ ist__s = min(ist, 1) ! 1 => Soil
+ ist__w = 1 - ist__s ! 1 => Water Body
+ ! +--Water Diffusion
+ ! + ^^^^^^^^^^^^^^^
+ ! Hydraulic Diffusivity DR97, Eqn.(3.36)
+ Dhydif = s1__SV(ist) &
+ * max(epsi, eta_SV(ikl, isl)) &
+ **(bCHdSV(ist) + 2.)
+ ! Water Bodies
+ Dhydif = ist__s * Dhydif &
+ + ist__w * vK_dSV
+ ! +--Water Conduction (without Horton Runoff)
+ ! + ^^^^^^^^^^^^^^^^
+ Khyd_f = Ks_dSV(ist)
+ ! +... Uses saturated K ==> Horton Runoff ~0 !
+#if(GH)
+ ! +--Water Conduction (with Horton Runoff)
+ ! + ^^^^^^^^^^^^^^^^
+ ik0 = nkhy * eta_SV(ikl, isl) &
+ / etadSV(ist)
+ eta__f = 1. &
+ -aKdtSV3(ist, ik0) / (2.*dzAvSV(isl) &
+ * LSdzsv(ikl))
+ eta__f = max(eps_21, eta__f)
+ eta__f = min(etadSV(ist), &
+ eta_SV(ikl, isl) + &
+ (aKdtSV3(ist, ik0) * eta_SV(ikl, isl) &
+ + bKdtSV3(ist, ik0)) / (dzAvSV(isl) &
+ * LSdzsv(ikl)) &
+ / eta__f)
+ eta__f = .5 * (eta_SV(ikl, isl) &
+ + eta__f)
+#if(gh)
+ eta__f = eta_SV(ikl, isl)
+#endif
+ ik0 = nkhy * eta__f &
+ / etadSV(ist)
+ Khyd_f = &
+ (aKdtSV3(ist, ik0) * eta__f &
+ + bKdtSV3(ist, ik0)) / dt__SV
+#endif
+ ! DR97 Assumption Water Bodies
+ Khydav = ist__s * Khyd_f &
+ + ist__w * vK_dSV
+ ! +--Gravitational Flow
+ ! + ^^^^^^^^^^^^^^^^^^
+ ! MAXimum Infiltration Rate
+ Wg_MAX = &
+ ro_Wat * Dhydif &
+ * (etadSV(ist) - eta_SV(ikl, isl)) &
+ / (dzAvSV(isl) * LSdzsv(ikl)) &
+ + ro_Wat * Khydav
+#if(WR)
+ write(6, 6001) isl, drr_SV(ikl) * 3.6e3, Wg_MAX * 3.6e3
+6001 format(i3, ' vRain ,Wg_MAX ', 2e12.3, ' mm/hr')
+#endif
+ ! Infiltration Rate
+ WgFlow = min(Wg_MAX, drr_SV(ikl))
+ ! Water Excess => RunOff
+ WExces = max(zero, drr_SV(ikl) - WgFlow)
+#if(WR)
+ write(6, 6002) WgFlow * 3.6e3, WExces * 3.6e3
+6002 format(3x, ' WgFlow,WExces ', 2e12.3, ' mm/hr')
+#endif
+ SoRnOF(ikl) = SoRnOF(ikl) + WExces
+ drr_SV(ikl) = WgFlow
+#if(WR)
+ write(6, 6003) SoRnOF(ikl) * 3.6e3, drr_SV(ikl) * 3.6e3
+6003 format(3x, ' SoRnOF,drr_SV ', 2e12.3, ' mm/hr')
+#endif
+ ! Saturation Rate
+ SatRat = (etadSV(ist) - eta_SV(ikl, isl)) &
+ * ro_Wat * dzAvSV(isl) &
+ * LSdzsv(ikl) / dt__SV
+ SatRat = min(SatRat, drr_SV(ikl))
+ ! Water Flux for Below
+ drr_SV(ikl) = drr_SV(ikl) - SatRat
+#if(WR)
+ write(6, 6004) SatRat * 3.6e3, drr_SV(ikl) * 3.6e3
+6004 format(3x, ' SatRat,drr_SV ', 2e12.3, ' mm/hr')
+#endif
+#if(WR)
+ write(6, 6005) eta_SV(ikl, isl) * 1.e3
+#endif
+ ! Saturation
+ eta_SV(ikl, isl) = eta_SV(ikl, isl) &
+ + SatRat * dt__SV &
+ / (ro_Wat * dzAvSV(isl) &
+ * LSdzsv(ikl))
+#if(WR)
+ write(6, 6005) eta_SV(ikl, isl) * 1.e3
+6005 format(3x, ' eta_SV, ', e12.3, ' g/kg')
+#endif
+ enddo
+ enddo
+ do ikl = 1, klonv
+ ! RunOFF Intensity [kg/m2/s]
+ SoRnOF(ikl) = SoRnOF(ikl) &
+ + drr_SV(ikl)
+ ! +!!! Inclure la possibilite de creer une mare sur un bedrock impermeable
+ drr_SV(ikl) = 0.
+ enddo
+#endif
+
+ ! +--Temperature Correction due to a changed Soil Energy Content
+ ! + ===========================================================
+
+ ! +!!! Mettre en oeuvre le couplage humidit?-?nergie
+
+ ! +--Full Resolution of the Richard's Equation
+ ! + =========================================
+
+ ! +... METHOD: Water content evolution results from water fluxes
+ ! + ^^^^^^ at the layer boundaries
+ ! + Conductivity is approximated by a piecewise linear profile.
+ ! + Semi-Implicit Crank-Nicholson scheme is used.
+ ! + (Bruen, 1997, Sensitivity of hydrological processes
+ ! + at the land-atmosphere interface.
+ ! + Proc. Royal Irish Academy, IGBP symposium
+ ! + on global change and the Irish Environment.
+ ! + Publ.: Maynooth)
+ ! + - - - - - - - - isl+1/2 - - ^
+ ! + |
+ ! + eta_SV(isl) --------------- isl ----- +--dz_dSV(isl) ^
+ ! + | |
+ ! + Dhydtz(isl) etaMid - - - - - - - - isl-1/2 - - v dzmiSV(isl)--+
+ ! + |
+ ! + eta_SV(isl-1) --------------- isl-1 ----- v
+
+ ! +--Transfert Coefficients
+ ! + ----------------------------
+
+ do isl = -nsol + 1, 0
+ do ikl = 1, klonv
+ ! Soil Type
+ ist = isotSV(ikl)
+ ! 1 => Soil
+ ist__s = min(ist, 1)
+ ! 1 => Water Body
+ ist__w = 1 - ist__s
+ ! eta at layers interface LSdzsv implicit
+ etaMid = (dz_dSV(isl) * eta_SV(ikl, isl - 1) &
+ + dz_dSV(isl - 1) * eta_SV(ikl, isl)) &
+ / (2.0 * dzmiSV(isl))
+#if(GA)
+ ! Idem, geometric average (Vauclin&al.1979)
+ etaMid = sqrt(dz_dSV(isl) * eta_SV(ikl, isl - 1) &
+ * dz_dSV(isl - 1) * eta_SV(ikl, isl)) &
+ / (2.0 * dzmiSV(isl))
+#endif
+ ! Hydraul.Diffusi. DR97, Eqn.(3.36)
+ Dhydif = s1__SV(ist) &
+ * (etaMid**(bCHdSV(ist) + 2.))
+ Dhydtz(ikl, isl) = Dhydif * dt__SV &
+ / (dzmiSV(isl) &
+ * LSdzsv(ikl))
+ ! Soil Water bodies
+ Dhydtz(ikl, isl) = Dhydtz(ikl, isl) * ist__s &
+ + 0.5 * dzmiSV(isl) * LSdzsv(ikl) * ist__w
+
+ enddo
+ enddo
+ isl = -nsol
+ do ikl = 1, klonv
+ Dhydtz(ikl, isl) = 0.0 !
+ enddo
+
+ ! +--Tridiagonal Elimination: Set Up
+ ! + -------------------------------
+
+ ! +--Soil/Snow Interior
+ ! + ^^^^^^^^^^^^^^^^^^
+
+ sum1 = 0
+ do isl = 0, -nsol, -1
+ do ikl = 1, klonv
+ eta_SV(ikl, isl) = max(epsi, eta_SV(ikl, isl))
+ sum1(ikl) = sum1(ikl) + eta_SV(ikl, isl) * dzAvSV(isl)
+ ! -dt__SV *Rootsv(ikl,isl)
+ ! /(ro_Wat *LSdzsv(ikl))
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ ! rainfall
+ sum1(ikl) = sum1(ikl) + dt__SV * drr_SV(ikl) / (ro_Wat * LSdzsv(ikl))
+ ! subli/evapo from soil
+ sum1(ikl) = sum1(ikl) + dt__SV * HLs_sv(ikl) * (1 - min(1, isnoSV(ikl))) &
+ / (Lx_H2O(ikl) * ro_Wat * LSdzsv(ikl))
+ ! evapotranspiration
+ sum1(ikl) = sum1(ikl) - dt__SV * EvT_SV(ikl) / (ro_Wat * LSdzsv(ikl))
+ if(isnoSV(ikl) == 0) then
+ wee_SV(ikl, 4) = wee_SV(ikl, 4) - dt__SV * HLs_sv(ikl) / Lx_H2O(ikl)
+ endif
+ enddo
+
+ do isl = -nsol, -nsol + 1
+ do ikl = 1, klonv
+ etaaux(ikl, isl) = eta_SV(ikl, isl)
+ enddo
+ enddo
+
+ do isl = -nsol + 1, -1
+ do ikl = 1, klonv
+ ist = isotSV(ikl)
+ ikm = nkhy * eta_SV(ikl, isl - 1) / etadSV(ist)
+ ik0 = nkhy * eta_SV(ikl, isl) / etadSV(ist)
+ ikp = nkhy * eta_SV(ikl, isl + 1) / etadSV(ist)
+ if(ikm < 0 .or. ik0 < 0 .or. ikp < 0) then
+ call time_steps
+ print *, "CRASH1 in sisvat_qso.f on pixel (i,j,n)", &
+ ii__SV(ikl), jj__SV(ikl), nn__SV(ikl)
+ print *, "decrease your time step or increase ntphys "// &
+ "and ntdiff in time_steps.f90"
+ stop
+ endif
+
+ Elem_A = Dhydtz(ikl, isl) &
+ - aKdtSV3(ist, ikm) * dziiSV(isl) * LSdzsv(ikl)
+ Elem_B = -(Dhydtz(ikl, isl) &
+ + Dhydtz(ikl, isl + 1) &
+ - aKdtSV3(ist, ik0) * (dziiSV(isl + 1) &
+ - dzi_SV(isl)) * LSdzsv(ikl))
+ Elem_C = Dhydtz(ikl, isl + 1) &
+ + aKdtSV3(ist, ikp) * dzi_SV(isl + 1) * LSdzsv(ikl)
+ Diag_A(ikl, isl) = dz_8SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_A
+ Diag_B(ikl, isl) = dz34SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_B
+ Diag_C(ikl, isl) = dz_8SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_C
+
+ Term_D(ikl, isl) = (dz_8SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_A) * eta_SV(ikl, isl - 1) &
+ + (dz34SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_B) * eta_SV(ikl, isl) &
+ + (dz_8SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_C) * eta_SV(ikl, isl + 1) &
+ + (bKdtSV3(ist, ikp) * dzi_SV(isl + 1) &
+ + bKdtSV3(ist, ik0) * (dziiSV(isl + 1) &
+ - dzi_SV(isl)) &
+ - bKdtSV3(ist, ikm) * dziiSV(isl)) &
+ * LSdzsv(ikl) &
+ - dt__SV * Rootsv(ikl, isl) / ro_Wat
+ enddo
+ enddo
+
+ isl = -nsol
+ do ikl = 1, klonv
+ ist = isotSV(ikl)
+ ! FreeDr = FreeD0 * min(ist,1)
+ FreeDr = iWaFSV(ikl) * min(ist, 1)
+ ik0 = nkhy * eta_SV(ikl, isl) / etadSV(ist)
+ ikp = nkhy * eta_SV(ikl, isl + 1) / etadSV(ist)
+
+ if(ik0 < 0 .or. ikp < 0) then
+ print *, "CRASH2 in sisvat_qso.f on pixel (i,j,n)", &
+ ii__SV(ikl), jj__SV(ikl), nn__SV(ikl)
+ print *, "decrease your time step or increase ntphys "// &
+ "and ntdiff in time_steps.f"
+ stop
+ endif
+
+ Elem_A = 0.
+ Elem_B = -(Dhydtz(ikl, isl + 1) &
+ - aKdtSV3(ist, ik0) * (dziiSV(isl + 1) * LSdzsv(ikl) &
+ - FreeDr))
+ Elem_C = Dhydtz(ikl, isl + 1) &
+ + aKdtSV3(ist, ikp) * dzi_SV(isl + 1) * LSdzsv(ikl)
+ Diag_A(ikl, isl) = 0.
+ Diag_B(ikl, isl) = dz78SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_B
+ Diag_C(ikl, isl) = dz_8SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_C
+
+ Term_D(ikl, isl) = (dz78SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_B) * eta_SV(ikl, isl) &
+ + (dz_8SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_C) * eta_SV(ikl, isl + 1) &
+ + (bKdtSV3(ist, ikp) * dzi_SV(isl + 1) * LSdzsv(ikl) &
+ + bKdtSV3(ist, ik0) * (dziiSV(isl + 1) * LSdzsv(ikl) &
+ - FreeDr)) &
+ - dt__SV * Rootsv(ikl, isl) / ro_Wat
+ enddo
+
+ isl = 0
+ do ikl = 1, klonv
+ ist = isotSV(ikl)
+ ikm = nkhy * eta_SV(ikl, isl - 1) / etadSV(ist)
+ ik0 = nkhy * eta_SV(ikl, isl) / etadSV(ist)
+ Elem_A = Dhydtz(ikl, isl) &
+ - aKdtSV3(ist, ikm) * dziiSV(isl) * LSdzsv(ikl)
+ Elem_B = -(Dhydtz(ikl, isl) &
+ + aKdtSV3(ist, ik0) * dzi_SV(isl) * LSdzsv(ikl))
+ Elem_C = 0.
+ Diag_A(ikl, isl) = dz_8SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_A
+ Diag_B(ikl, isl) = dz78SV(isl) * LSdzsv(ikl) &
+ - Implic * Elem_B
+ Diag_C(ikl, isl) = 0.
+ ! +
+ Term_D(ikl, isl) = (dz_8SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_A) * eta_SV(ikl, isl - 1) &
+ + (dz78SV(isl) * LSdzsv(ikl) &
+ + Explic * Elem_B) * eta_SV(ikl, isl) &
+ - (bKdtSV3(ist, ik0) * dzi_SV(isl) &
+ + bKdtSV3(ist, ikm) * dziiSV(isl)) * LSdzsv(ikl) &
+ + dt__SV * (HLs_sv(ikl) * 1.*(1 - min(1, isnoSV(ikl))) &
+ / (ro_Wat * dz_dSV(0) * Lx_H2O(ikl)) &
+ + drr_SV(ikl) &
+ - Rootsv(ikl, isl)) / ro_Wat
+ enddo
+
+ do ikl = 1, klonv
+ drr_SV(ikl) = 0. ! drr is included in the 1st soil layer
+ enddo
+
+ ! +
+ ! +
+ ! +--Tridiagonal Elimination
+ ! + =======================
+ ! +
+ ! +--Forward Sweep
+ ! + ^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ Aux__P(ikl, -nsol) = Diag_B(ikl, -nsol)
+ Aux__Q(ikl, -nsol) = -Diag_C(ikl, -nsol) / Aux__P(ikl, -nsol)
+ enddo
+ ! +
+ do isl = -nsol + 1, 0
+ do ikl = 1, klonv
+ Aux__P(ikl, isl) = Diag_A(ikl, isl) * Aux__Q(ikl, isl - 1) &
+ + Diag_B(ikl, isl)
+ Aux__Q(ikl, isl) = -Diag_C(ikl, isl) / Aux__P(ikl, isl)
+ enddo
+ enddo
+ ! +
+ do ikl = 1, klonv
+ eta_SV(ikl, -nsol) = Term_D(ikl, -nsol) / Aux__P(ikl, -nsol)
+ enddo
+ ! +
+ do isl = -nsol + 1, 0
+ do ikl = 1, klonv
+ eta_SV(ikl, isl) = (Term_D(ikl, isl) &
+ - Diag_A(ikl, isl) * eta_SV(ikl, isl - 1)) &
+ / Aux__P(ikl, isl)
+ enddo
+ enddo
+
+ ! +--Backward Sweep
+ ! + ^^^^^^^^^^^^^^
+ do isl = -1, -nsol, -1
+ do ikl = 1, klonv
+ eta_SV(ikl, isl) = Aux__Q(ikl, isl) * eta_SV(ikl, isl + 1) &
+ + eta_SV(ikl, isl)
+ enddo
+ enddo
+
+ ! +--Horton RunOFF Intensity
+ ! + =======================
+ do isl = 0, -nsol, -1
+ do ikl = 1, klonv
+ ! Soil Type
+ ist = isotSV(ikl)
+ ! OverSaturation Rate
+ SatRat = (eta_SV(ikl, isl) - etadSV(ist)) &
+ * ro_Wat * dzAvSV(isl) &
+ * LSdzsv(ikl) &
+ / dt__SV
+ SoRnOF(ikl) = SoRnOF(ikl) + max(zero, SatRat)
+ SoRnOF2(ikl) = SoRnOF2(ikl) + max(zero, SatRat)
+ RuofSV(ikl, 5) = RuofSV(ikl, 5) + max(zero, SatRat)
+ eta_SV(ikl, isl) = max(epsi, eta_SV(ikl, isl))
+ eta_SV(ikl, isl) = min(eta_SV(ikl, isl), etadSV(ist))
+ enddo
+ enddo
+
+ ! +--IO, for Verification
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ ! #if(WR)
+ ! write(6, 6010)
+ ! 6010 format(/, 1x)
+ ! #endif
+ ! do isl = 0, -nsol, -1
+ ! do ikl = 1, klonv
+ ! ist = isotSV(ikl)
+ ! ikp = nkhy * eta_SV(ikl, isl) / etadSV(ist)
+ ! Khydsv(ikl, isl) = (aKdtSV3(ist, ikp) * eta_SV(ikl, isl)&
+ ! + bKdtSV3(ist, ikp)) * 2.0 / dt__SV
+ ! #if(WR)
+ ! write(6, 6011) ikl, isl, eta_SV(ikl, isl) * 1.e3, &
+ ! ikp, aKdtSV3(ist, ikp), bKdtSV3(ist, ikp), &
+ ! Khydsv(ikl, isl)
+ ! #endif
+ ! 6011 format(2i3, f8.1, i3, 3e12.3)
+ ! end do
+ ! end do
+
+ ! +--Additional RunOFF Intensity
+ ! + ===========================
+ do ikl = 1, klonv
+ ist = isotSV(ikl)
+ ik0 = nkhy * etaaux(ikl, -nsol) / etadSV(ist)
+ ! FreeDr = FreeD0 * min(ist,1)
+ FreeDr = iWaFSV(ikl) * min(ist, 1)
+ WExces = (aKdtSV3(ist, ik0) * (etaaux(ikl, -nsol) * Explic &
+ + eta_SV(ikl, -nsol) * Implic) &
+ + bKdtSV3(ist, ik0)) &
+ * FreeDr * ro_Wat / dt__SV
+
+ eta_SV(ikl, -nsol) = eta_SV(ikl, -nsol) - WExces * dt__SV &
+ / (ro_Wat * dzAvSV(-nsol) * LSdzsv(ikl))
+ SoRnOF(ikl) = SoRnOF(ikl) + WExces
+ SoRnOF2(ikl) = SoRnOF2(ikl) + WExces
+ RuofSV(ikl, 6) = RuofSV(ikl, 6) + WExces
+
+ ! +--Full Run OFF: Update
+ ! + ~~~~~~~~~~~~~~~~~~~~
+ RnofSV(ikl) = RnofSV(ikl) + SoRnOF(ikl)
+ enddo
+
+ ! +--Mass conservation
+ ! + ^^^^^^^^^^^^^^^^^
+ sum2 = 0
+ do ikl = 1, klonv
+ do isl = 0, -nsol, -1
+ eta_SV(ikl, isl) = max(epsi, eta_SV(ikl, isl))
+ sum2(ikl) = sum2(ikl) + eta_SV(ikl, isl) * dzAvSV(isl)
+ enddo
+ sum2(ikl) = sum2(ikl) + dt__SV * SoRnOF2(ikl) / (ro_Wat * LSdzsv(ikl))
+ enddo
+
+ do ikl = 1, klonv
+ if(isotSV(ikl) > 0) then
+ do isl = -nsol + 2, -nsol, -1
+ eta_SV(ikl, isl) = eta_SV(ikl, isl) + (sum1(ikl) - sum2(ikl)) &
+ / (3.*dzAvSV(isl))
+ eta_SV(ikl, isl) = max(epsi, eta_SV(ikl, isl))
+ enddo
+ endif
+ enddo
+
+ ! +--Temperature Correction due to a changed Soil Energy Content
+ ! + ===========================================================
+
+ ! +!!! Mettre en oeuvre le couplage humidit?-?nergie
+
+ ! +--Bumps/Asperites Treatment
+ ! + =========================
+
+ ! +--Average over Bump Depth (z0soil)
+ ! + --------------------------------
+#if(BP)
+ z_Bump = 0.
+ do ikl = 1, klonv
+ etBump(ikl) = 0.
+ enddo
+ do isl = 0, -nsol, -1
+ z0Bump = z_Bump
+ z_Bump = z_Bump + dzAvSV(isl)
+ if(z_Bump < z0soil) then
+ do ikl = 1, klonv
+ etBump(ikl) = etBump(ikl) + dzAvSV(isl) * eta_SV(ikl, isl)
+ enddo
+ endif
+ if(z_Bump > z0soil .and. z0Bump < z0soil) then
+ do ikl = 1, klonv
+ etBump(ikl) = etBump(ikl) + (z0soil - z0Bump) * eta_SV(ikl, isl)
+ etBump(ikl) = etBump(ikl) / z0soil
+ enddo
+ endif
+ enddo
+ ! +--Correction
+ ! + ----------
+ z_Bump = 0.
+ do isl = 0, -nsol, -1
+ z0Bump = z_Bump
+ z_Bump = z_Bump + dzAvSV(isl)
+ if(z_Bump < z0soil) then
+ do ikl = 1, klonv
+ eta_SV(ikl, isl) = etBump(ikl)
+ enddo
+ endif
+ if(z_Bump > z0soil .and. z0Bump < z0soil) then
+ dzBump = z_Bump - z0soil
+ do ikl = 1, klonv
+ eta_SV(ikl, isl) = (etBump(ikl) * (dzAvSV(isl) - dzBump) &
+ + eta_SV(ikl, isl) * dzBump) &
+ / dzAvSV(isl)
+ enddo
+ endif
+ enddo
+ ! +--Positive Definite
+ ! + =================
+ do isl = 0, -nsol, -1
+ do ikl = 1, klonv
+ eta_SV(ikl, isl) = max(epsi, eta_SV(ikl, isl))
+ enddo
+ enddo
+#endif
+#if(m0)
+ ! +--Water Budget (OUT)
+ ! + ===================
+ do ikl = 1, klonv
+ ! Precipitation is already included + Evaporation + Soil RunOFF Contrib.
+ Wats_d(ikl) = Wats_d(ikl) &
+ + drr_SV(ikl) * zero &
+ + HLs_sv(ikl) &
+ * (1 - min(isnoSV(ikl), 1)) / Lx_H2O(ikl) &
+ - SoRnOF(ikl)
+ Wats_1(ikl) = 0.
+#if(mw)
+ Evapor(ikl) = HLs_sv(ikl) * dt__SV &
+ * (1 - min(isnoSV(ikl), 1)) / Lx_H2O(ikl)
+#endif
+ enddo
+ do isl = -nsol, 0
+ do ikl = 1, klonv
+ ! Root Extract.
+ Wats_d(ikl) = Wats_d(ikl) - Rootsv(ikl, isl)
+ enddo
+ enddo
+ do ikl = 1, klonv
+ Wats_d(ikl) = Wats_d(ikl) * dt__SV !
+ enddo
+ isl = -nsol
+ do ikl = 1, klonv
+ Wats_1(ikl) = Wats_1(ikl) &
+ + ro_Wat * (eta_SV(ikl, isl) * dz78SV(isl) &
+ + eta_SV(ikl, isl + 1) * dz_8SV(isl)) * LSdzsv(ikl)
+ enddo
+ do isl = -nsol + 1, -1
+ do ikl = 1, klonv
+ Wats_1(ikl) = Wats_1(ikl) &
+ + ro_Wat * (eta_SV(ikl, isl) * dz34SV(isl) &
+ + (eta_SV(ikl, isl - 1) &
+ + eta_SV(ikl, isl + 1)) * dz_8SV(isl)) * LSdzsv(ikl)
+ enddo
+ enddo
+ isl = 0
+ do ikl = 1, klonv
+ Wats_1(ikl) = Wats_1(ikl) &
+ + ro_Wat * (eta_SV(ikl, isl) * dz78SV(isl) &
+ + eta_SV(ikl, isl - 1) * dz_8SV(isl)) * LSdzsv(ikl)
+ enddo
+#endif
+#if(mw)
+ ! +--Water Budget (IO)
+ ! + ==================
+ if(.not. mwopen) then
+ mwopen = .true.
+ open(unit=42, status='unknown', file='SISVAT_qSo.vw')
+ rewind 42
+ write(42, 42)
+42 format('subroutine SISVAT_qSo: Local Water Budget', &
+ /, '=========================================')
+ endif
+ timewr = timewr + dt__SV
+ hourwr = 3600.0
+ if(mod(timewr, hourwr) < epsi) write(42, 420) timewr / hourwr
+420 format(11('-'), '----------+--------------+-', &
+ 3('-'), '----------+--------------+-', &
+ '----------------+----------------+', &
+ /, f8.2, 3x, 'Wats_0(1) | Wats_d(1) | ', &
+ 3x, 'Wats_1(1) | W_0+W_d-W_1 | ', &
+ ' Soil Run OFF | Soil Evapor. |', &
+ /, 11('-'), '----------+--------------+-', &
+ 3('-'), '----------+--------------+-', &
+ '----------------+----------------+')
+ write(42, 421) Wats_0(1), Wats_d(1) &
+ , Wats_1(1) &
+ , Wats_0(1) + Wats_d(1) - Wats_1(1) &
+ , SoRnOF(1), Evapor(1)
+421 format(8x, f12.6, ' + ', f12.6, ' - ', f12.6, ' = ', f12.6, ' | ', f12.6, &
+ ' ', f15.6)
+#endif
+ return
+end
diff --git a/MAR/code_mar/sisvat_qvg.f90 b/MAR/code_mar/sisvat_qvg.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b3816101bd49d4fd4f1b1e7cde699e28cacf047c
--- /dev/null
+++ b/MAR/code_mar/sisvat_qvg.f90
@@ -0,0 +1,247 @@
+subroutine SISVAT_qVg
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_qVg 22-09-2001 MAR |
+ ! | subroutine SISVAT_qVg computes the Canopy Water Balance |
+ ! | including Root Extraction |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: ivgtSV = 0,...,12: Vegetation Type |
+ ! | ^^^^^ 0: Water, Solid or Liquid |
+ ! | |
+ ! | INPUT: rhT_SV : SBL Top Air Density [kg/m3] |
+ ! | ^^^^^ QaT_SV : SBL Top Specific Humidity [kg/kg] |
+ ! | |
+ ! | TvegSV : Canopy Temperature [K] |
+ ! | rrCaSV : Canopy Water Content [kg/m2] |
+ ! | rrMxsv : Canopy Maximum Intercepted Rain [kg/m2] |
+ ! | rah_sv : Aerodynamic Resistance for Heat [s/m] |
+ ! | EvT_sv : EvapoTranspiration [kg/m2] |
+ ! | Sigmsv : Canopy Ventilation Factor [-] |
+ ! | glf_sv : Green Leaf Fraction of NOT fallen Leaves [-] |
+ ! | LAIesv : Leaf Area Index (effective / transpiration) [-] |
+ ! | psi_sv : Soil Water Potential [m] |
+ ! | Khydsv : Soil Hydraulic Conductivity [m/s] |
+ ! | |
+ ! | INPUT / psivSV : Leaf Water Potential [m] |
+ ! | OUTPUT: |
+ ! | ^^^^^^ |
+ ! | |
+ ! | OUTPUT: Rootsv : Root Water Pump [kg/m2/s] |
+ ! | ^^^^^^ |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | |
+ ! | REMARK: Water Extraction by roots calibrated by Evapotranspiration |
+ ! | ^^^^^^ (computed in the Canopy Energy Balance) |
+ ! | |
+ ! | # OPTIONS: #KW: Root Water Flow slowed by Soil Hydraulic Conductivity |
+ ! | # ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--Internal Variables
+ ! + ==================
+ ! ikl, isl : Grid Point, Layer Indices
+ integer ikl, isl
+ ! nitmax, nit : Iterations Counter
+ integer nitmax, nit
+ ! PlantW : Plant Water
+ real PlantW(klonv)
+ ! dPdPsi : Plant Water psi Derivative
+ real dPdPsi(klonv)
+ ! psidif : Soil-Canopy Water Pot. Differ.
+ real psidif
+ ! Root_W : Root Water Flow
+ real Root_W
+ ! RootOK : Roots take Water in Soil Layer
+ real RootOK
+ ! d_psiv : Canopy Water Increment
+ real d_psiv
+ ! dpvMAX : Canopy Water Increment MAX
+ real dpvMAX
+ ! BWater : Imbalance of Canopy Water Budg.
+ real BWater
+ ! BW_MAX : MAX Imbal.of Canopy Water Budg.
+ real BW_MAX
+ ! BW_MIN : MIN Imbal.of Canopy Water Budg.
+ real BW_MIN
+ ! dBwdpv : Derivativ.of Canopy Water Budg.
+ real dBwdpv
+ ! Bswich : Newton-Raphson Switch
+ real Bswich
+ ! psiv_0 : Canopy Temperature, Previous t
+ real psiv_0(klonv)
+ ! EvFrac : Condensat./Transpiration Switch
+ real EvFrac
+ ! den_qs, arg_qs, qsatvg : Canopy Saturat. Spec. Humidity
+ real den_qs, arg_qs, qsatvg
+ ! EvTran : EvapoTranspiration
+ real EvTran
+ ! dEdpsi : Evapotranspiration Derivative
+ real dEdpsi
+ ! Fac_Ev, FacEvT : Evapotranspiration Factors
+ real Fac_Ev, FacEvT
+ ! denomE : Evapotranspiration Denominator
+ real denomE
+ ! F_Stom : Funct. (Leaf Water Potential)
+ real F_Stom
+ ! dFdpsi : Derivative of F_Stom
+ real dFdpsi
+ ! denomF : Denominator of F_Stom
+ real denomF
+ ! F___OK : (psi>psi_c) => F_Stom swich ON
+ real F___OK
+ ! R0Stom : Minimum Stomatal Resistance
+ real R0Stom
+ ! R_Stom : Stomatal Resistance
+ real R_Stom
+ ! dRdpsi : Derivat.Stomatal Resistance
+ real dRdpsi
+ ! numerR : Numerat.Stomatal Resistance
+ real numerR
+
+ ! +--Internal DATA
+ ! + =============
+ ! nitmax : Maximum Iterations Number
+ data nitmax/5/
+ ! dpvMAX : Canopy Water Increment MAX
+ data dpvMAX/20./
+ ! BW_MIN : MIN Imbal. of Surf.Energy Budg.
+ data BW_MIN/4.e-8/
+
+ ! +--Newton-Raphson Scheme
+ ! + =====================
+ nit = 0
+101 continue
+ nit = nit + 1
+ BW_MAX = 0.
+
+ ! +--W.Potential of the Previous Time Step
+ ! + -------------------------------------
+ do ikl = 1, klonv
+ psiv_0(ikl) = psivSV(ikl)
+ ! +--Extraction of Soil Water through the Plant Roots
+ ! + ------------------------------------------------
+ ! PlantW : Plant Water
+ PlantW(ikl) = 0.
+ ! dPdPsi : Idem, Derivat.
+ dPdPsi(ikl) = 0.
+ enddo
+ do isl = -nsol, 0
+ do ikl = 1, klonv
+ ! Soil-Canopy Water
+ psidif = psivSV(ikl) - (DH_dSV(ivgtSV(ikl)) &
+ + psi_sv(ikl, isl)) ! Potential Diff.
+ ! If > 0, Contrib. to Root Water
+ Root_W = Ro_Wat * RF__SV(ivgtSV(ikl), isl) &
+ / max(eps_21, PR_dSV(ivgtSV(ikl)))
+ ! +!!! Pas de prise en compte de la resistance sol/racine dans proto-svat
+ ! + (DR97, eqn.3.20)
+ RootOK = max(zero, sign(unun, psidif))
+ Rootsv(ikl, isl) = Root_W * max(zero, psidif) ! Root Water
+ PlantW(ikl) = PlantW(ikl) + Rootsv(ikl, isl) ! Plant Water
+ dPdPsi(ikl) = dPdPsi(ikl) + RootOK * Root_W ! idem, Derivat.
+ enddo
+ enddo
+
+ ! +--Latent Heat Flux
+ ! + ------------------
+
+ ! +--Canopy Saturation Specific Humidity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ den_qs = TvegSV(ikl) - 35.8
+ arg_qs = 17.27 * (TvegSV(ikl) - 273.16) / den_qs
+ qsatvg = .0038 * exp(arg_qs)
+ !XF qsatvg = .0038 * exp(arg_qs) * 0.875 ! A TESTER 04/2019
+
+ ! +--Canopy Stomatal Resistance
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ R0Stom = min(StodSV(ivgtSV(ikl)) &
+ / max(epsi, glf_sv(ikl)), StxdSV) ! Min Stomatal R.
+ denomF = pscdSV - psivSV(ikl)
+ F___OK = max(zero, sign(unun, denomF))
+ denomF = max(epsi, denomF) !
+ F_Stom = pscdSV / denomF ! F(Leaf Wat.Pot.)
+ dFdpsi = -F_Stom / denomF !
+ ! + ! DR97, eqn. 3.22
+ numerR = R0Stom / max(LAIesv(ikl), R0Stom / StxdSV) !
+ R_Stom = numerR * F_Stom ! Can.Stomatal R.
+ ! + ! DR97, eqn. 3.21
+ dRdpsi = R_Stom * dFdpsi !
+
+ ! +--Evaporation / Evapotranspiration
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ EvFrac = max(zero, sign(unun, QaT_SV(ikl) - qsatvg)) ! Condensation/
+ ! Transpiration Switch
+ EvFrac = EvFrac &
+ + (1.-EvFrac) * rrCaSV(ikl) / rrMxsv(ikl)
+ ! idem, Factor
+ Fac_Ev = rhT_SV(ikl) * Sigmsv(ikl)
+ denomE = rah_sv(ikl) + R_Stom * Sigmsv(ikl)
+ FacEvT = Fac_Ev * (1.-EvFrac) / denomE
+ ! EvapoTranspir.
+ EvTran = FacEvT * (qsatvg - QaT_SV(ikl))
+ ! EvT Derivative
+ dEdpsi = (EvTran / denomE) * dRdpsi
+
+ ! +--Imbalance of the Canopy Water Budget
+ ! + ---------------------------------------
+
+ ! Available Water
+ BWater = (PlantW(ikl) &
+ ! Transpired Water
+ - EvTran) * F___OK
+ ! Newton-Raphson Switch
+ Bswich = max(zero, &
+ sign(unun, abs(BWater) &
+ - BW_MIN))
+
+ ! +--Derivative of the Canopy Water Budget
+ ! + ---------------------------------------
+
+ dBwdpv = dPdpsi(ikl) &
+ - dEdpsi
+ dBwdpv = sign(unun, dBwdpv) &
+ * max(eps_21, abs(dBwdpv))
+
+ ! +--Update Canopy and Surface/Canopy Temperatures
+ ! + ---------------------------------------------
+
+ d_psiv = BWater / dBwdpv
+ ! Increment Limitor
+ d_psiv = sign(unun, d_psiv) &
+ * min(abs(d_psiv), dpvMAX)
+ ! Newton-Raphson
+ psivSV(ikl) = psivSV(ikl) - Bswich * d_psiv
+ BW_MAX = max(BW_MAX, abs(BWater))
+ enddo
+
+ ! +--Update Root Water Fluxes | := Evapotranspiration
+ ! + ------------------------------------------------
+
+ do isl = -nsol, 0
+ do ikl = 1, klonv
+ ! Root Water
+ Rootsv(ikl, isl) = Rootsv(ikl, isl) * EvT_SV(ikl) &
+ / max(eps_21, PlantW(ikl))
+ enddo
+ enddo
+
+ if(BW_MAX > BW_MIN .and. nit < nitmax) go to 101
+
+ return
+end
diff --git a/MAR/code_mar/sisvat_sic.f90 b/MAR/code_mar/sisvat_sic.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c0bdd9b00f081beb2c0c45b1d171a8da5e694a6e
--- /dev/null
+++ b/MAR/code_mar/sisvat_sic.f90
@@ -0,0 +1,133 @@
+#include "MAR_pp.def"
+subroutine SISVAT_SIc(SIvAcr)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_SIc 26-09-2006 MAR |
+ ! | subroutine SISVAT_SIc treats Sea-Ice and Ocean Latent Heat Exchanges |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: TaT_SV : SBL Top Temperature [K] |
+ ! | ^^^^^ isnoSV : total Nb of Ice/Snow Layers [-] |
+ ! | LSmask : Land-Sea Mask [-] |
+ ! | dsn_SV : Snow Intensity [mm w.e./s] |
+ ! | |
+ ! | INPUT / TsisSV : Snow/Ice/Soil-Water Temperature [K] |
+ ! | OUTPUT: eta_SV : Soil/Snow Water Content [m3/m3] |
+ ! | ^^^^^^ dzsnSV : Snow Layer Thickness [m] |
+ ! | |
+ ! | OUTPUT: HFraSV : Frazil Thickness [m] |
+ ! | ^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use marxsv
+
+ implicit none
+
+ ! +--INPUT/OUTPUT
+ ! + ------------
+
+ real SIvAcr(klonv) ! Sea-Ice Vertical Acretion
+
+ ! +--Local Variables
+ ! + ===============
+
+ integer ikl, isn
+ real OCN_OK
+ real SIceOK
+ real SIcFrz
+ real Twat_n
+ real Crodzw, Lro__I
+ common / SISVAT_SIc_R / Crodzw, Lro__I
+ logical SIcINI
+ common / SISVAT_SIc_L / SIcINI
+
+ real SalIce ! Sea-Ice Salinity
+ real SalWat ! Sea-Water Salinity
+
+ ! +--DATA
+ ! + ====
+
+ data SalIce/10./ ! Sea-Ice Salinity
+ data SalWat/35./ ! Sea-Water Salinity
+ ! +... Typical Salinities in Terra Nova Bay
+ ! + (Bromwich and Kurtz, 1984, JGR, p.3568;
+ ! + Cavalieri and Martin, 1985, p. 248)
+
+ ! +--Initialisation
+ ! + ==============
+
+ if(.not. SIcINI) then
+ SIcINI = .true.
+ ! [J/m2/K]
+ Crodzw = C__Wat * ro_Wat * dz_dSV(0)
+ ! [J/m3]
+ Lro__I = Lf_H2O * ro_Ice * (1.-1.e-3 * SalIce &
+ - (SalIce / SalWat) * (1.-1.e-3 * SalWat))
+#if(e1)
+ Lro__I = Lf_H2O * ro_Ice
+#endif
+ endif
+
+ ! +--Snow Fall cools Sea Water
+ ! + =========================
+
+ do ikl = 1, klonv
+ ! (1 - LSmask(ikl)) : Free Ocean
+ OCN_OK = (1 - LSmask(ikl)) * max(0, 1 - isnoSV(ikl))
+#if(IA)
+ ! [K]
+ ! [J/kg]
+ ! [J/kg]
+ ! [kg/m2]
+ TsisSV(ikl, 0) = TsisSV(ikl, 0) &
+ - OCN_OK * (Cn_dSV * (TfSnow - TaT_SV(ikl)) &
+ + Lf_H2O * (1.-eta_SV(ikl, 0))) &
+ * dsn_SV(ikl) * dt__SV / Crodzw
+#endif
+
+ ! +--Sea-Ice Formation
+ ! + =================
+#if(IA)
+ ! +*** Hibler (1984), Ocean Heat Flux: 25% of cooling (ANTARCTIC Ocean)
+ ! + (Hansen and Takahashi Eds)
+ ! + Geophys. Monogr. 29, M. Ewing Vol. 5, AGU, p. 241
+ ! [K]
+ Twat_n = max(TsisSV(ikl, 0), tfrwat)
+ ! [m]
+ SIcFrz = (Twat_n - TsisSV(ikl, 0)) * Crodzw / Lro__I * 0.75
+ ! +--Frazil Formation
+ ! + -----------------
+ HFraSV(ikl) = SIcFrz * OCN_OK
+ ! +--Growth of the Sea-Ice First Ice Floe
+ ! + ------------------------------------
+ ! Ice Cover.Ocean
+ SIceOK = (1 - LSmask(ikl)) &
+ * min(1, isnoSV(ikl))
+ ! Vertical Acret.
+ dzsnSV(ikl, 1) = dzsnSV(ikl, 1) &
+ + SIcFrz * SIceOK
+#endif
+ ! +--Diagnostic of the Surface Mass Balance
+ ! + --------------------------------------
+#if(m2)
+ SIvAcr(ikl) = ro_Ice * SIcFrz * (OCN_OK + SIceOK) &
+ - dt__SV * dsn_SV(ikl) * OCN_OK
+#else
+ SIvAcr(ikl) = 0.
+#endif
+
+ ! +--Water Fluxes Update
+ ! + -------------------
+
+ RnofSV(ikl) = RnofSV(ikl) &
+ + dsn_SV(ikl) * OCN_OK
+ RuofSV(ikl, 1) = RuofSV(ikl, 1) &
+ + dsn_SV(ikl) * OCN_OK
+ dsn_SV(ikl) = dsn_SV(ikl) * (1.-OCN_OK)
+
+ enddo
+
+ return
+endsubroutine SISVAT_SIc
diff --git a/MAR/code_mar/sisvat_sno_albedo.f90 b/MAR/code_mar/sisvat_sno_albedo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..29bd8ec23da87008ccb99c1991f4472478a95de8
--- /dev/null
+++ b/MAR/code_mar/sisvat_sno_albedo.f90
@@ -0,0 +1,637 @@
+#include "MAR_pp.def"
+subroutine SnOptP
+ ! +------------------------------------------------------------------------+
+ ! | MAR/SISVAT SnOptP 15-04-2021 MAR |
+ ! | subroutine SnOptP computes the Snow Pack optical Properties |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental Grid Boxes |
+ ! | X Number of Mosaic Cell per Grid Box |
+ ! | |
+ ! | INPUT: isnoSV = total Nb of Ice/Snow Layers |
+ ! | ^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer |
+ ! | |
+ ! | ivgtSV = 0,...,12: Vegetation Type |
+ ! | 0: Water, Solid or Liquid |
+ ! | |
+ ! | INPUT: G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+ ! | ^^^^^ G2snSV : Sphericity (>0) or Size of Snow Layer |
+ ! | agsnSV : Snow Age [day] |
+ ! | ro__SV : Snow/Soil Volumic Mass [kg/m3] |
+ ! | eta_SV : Water Content [m3/m3] |
+ ! | rusnSV : Surficial Water Thickness [kg/m2] .OR. [mm] |
+ ! | SWS_SV : Surficial Water Status |
+ ! | dzsnSV : Snow Layer Thickness [m] |
+ ! | |
+ ! | albssv : Soil Albedo [-] |
+ ! | zzsnsv : Snow Pack Thickness [m] |
+ ! | |
+ ! | OUTPUT: albisv : Snow/Ice/Water/Soil Integrated Albedo [-] |
+ ! | ^^^^^^ sEX_sv : Verticaly Integrated Extinction Coefficient |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | SnOpSV : Snow Grain optical Size [m] |
+ ! | EX1_sv : Integrated Snow Extinction (0.3--0.8micr.m) |
+ ! | EX2_sv : Integrated Snow Extinction (0.8--1.5micr.m) |
+ ! | EX3_sv : Integrated Snow Extinction (1.5--2.8micr.m) |
+ ! | |
+ ! | METHODE: Calcul de la taille optique des grains ? partir de |
+ ! | ^^^^^^^ -leur type decrit par les deux variables descriptives |
+ ! | continues sur la plage -99/+99 passees en appel. |
+ ! | -la taille optique (1/10mm) des etoiles, |
+ ! | des grains fins et |
+ ! | des jeunes faces planes |
+ ! | |
+ ! | METHOD: Computation of the optical diameter of the grains |
+ ! | ^^^^^^ described with the CROCUS formalism G1snSV / G2snSV |
+ ! | |
+ ! | REFERENCE: Brun et al. 1989, J. Glaciol 35 pp. 333--342 |
+ ! | ^^^^^^^^^ Brun et al. 1992, J. Glaciol 38 pp. 13-- 22 |
+ ! | Eric Martin Sept.1996 |
+ ! | |
+ ! | # OPTIONS: #AG: Generalisation of Col de Porte Ageing Parameterization |
+ ! | # ^^^^^^^ #CZ: Albedo Correction (Zenith Angle) |
+ ! | # #AW: Output of Soil-Ice-Snow Albedo |
+ ! | |
+ ! | CAUTION: Vegetation is not taken into account in albedo computations |
+ ! | ^^^^^^^ Suggestion: 1) Reduce the displacement height and/or LAI |
+ ! | (when snow) for radiative transfert through vegetation |
+ ! | 2) Adapt leaf optical parameters |
+ ! | |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SnOptP____.va | #va: OUTPUT/Verification: Albedo Parameteriz. |
+ ! | | unit 46, subroutine SnOptP **ONLY** |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use mar_ge
+ use margrd
+ use mar_sv
+ use mardsv
+ use marxsv
+ use marysv
+#if(CP)
+ use marcdp
+#endif
+#if(AO)
+ use mar_ao
+#endif
+
+ implicit none
+
+ ! +--Internal Variables
+ ! + ==================
+
+ real coalb1(klonv) ! weighted Coalbedo, Vis.
+ real coalb2(klonv) ! weighted Coalbedo, nIR 1
+ real coalb3(klonv) ! weighted Coalbedo, nIR 2
+ real coalbm ! weighted Coalbedo, mean
+ real sExt_1(klonv) ! Extinction Coeff., Vis.
+ real sExt_2(klonv) ! Extinction Coeff., nIR 1
+ real sExt_3(klonv) ! Extinction Coeff., nIR 2
+ real SnOpSV(klonv, nsno) ! Snow Grain optical Size
+#if(AG)
+ real agesno
+#endif
+
+ integer i, j, k, m
+ integer isn, ikl, isn1, jjtime
+ real sbeta1, sbeta2, sbeta3, sbeta4, sbeta5
+ real AgeMax, AlbMin, HSnoSV, HIceSV, doptmx, SignG1, Sph_OK
+ real dalbed, dalbeS, dalbeW
+ real bsegal, czemax, csegal
+ real RoFrez, DiffRo, SignRo, SnowOK, OpSqrt
+ real albSn1, albIc1, a_SnI1, a_SII1
+ real albSn2, albIc2, a_SnI2, a_SII2
+ real albSn3, albIc3, a_SnI3, a_SII3
+ real albSno, albIce, albSnI, albSII, albWIc, albmax
+ real doptic, Snow_H, SIce_H, SnownH, SIcenH
+ real exarg1, exarg2, exarg3, sign_0, sExt_0
+ real albedo_old, albCor
+ real ro_ave, dz_ave, minalb
+
+ ! +--OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(SR)
+ integer iSRwri, jSRwri, nSRwri, kSRwri, lSRwri
+ common / SISVAT_trace / iSRwri, jSRwri, nSRwri, kSRwri, lSRwri
+#endif
+
+ ! +--Albedo: IO
+ ! + ~~~~~~~~~~
+ ! IO Switch
+#if(va)
+ logical aw_opn
+ common / SnOptP_L / aw_opn
+#endif
+
+ ! +--Local DATA
+ ! + ============
+
+ ! +--For the computation of the solar irradiance extinction in snow
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ data sbeta1/0.0192/, sbeta2/0.4000/, sbeta3/0.1098/
+ data sbeta4/1.0000/
+ data sbeta5/2.00e1/
+
+ ! +--Snow Age Maximum (Taiga, e.g. Col de Porte)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ data AgeMax/60.0/
+ ! +... AgeMax: Snow Age Maximum [day]
+
+ data AlbMin/0.94/
+ ! +... AlbMin: Albedo Minimum / visible (0.3--0.8 micrometers)
+
+ data HSnoSV/0.01/
+ ! +... HSnoSV: Snow Thickness through witch
+ ! + Albedo is interpolated to Ice Albedo
+ data HIceSV/0.10/
+ ! +... HIceSV: Snow/Ice Thickness through witch
+ ! + Albedo is interpolated to Soil Albedo
+ data doptmx/2.3e-3/
+ ! +... doptmx: Maximum optical Diameter (pi * R**2) [m]
+ ! +
+ data czeMAX/0.173648178/ ! 80.deg (Segal et al., 1991 JAS)
+ data bsegal/4.00/ !
+ data albmax/0.99/ ! Albedo max
+
+ ! +--Snow Grain optical Size
+ ! + =======================
+
+ do ikl = 1, klonv
+ do isn = 1, max(1, isnoSV(ikl))
+
+ G2snSV(ikl, isn) = max(epsi, G2snSV(ikl, isn))
+ ! +... Avoid non physical Values
+
+ SignG1 = sign(unun, G1snSV(ikl, isn))
+ Sph_OK = max(zero, SignG1)
+
+ SnOpSV(ikl, isn) = 1.e-4 * &
+ (Sph_OK * (G2snSV(ikl, isn) * G1snSV(ikl, isn) / G1_dSV &
+ + max(demi * G2snSV(ikl, isn), DFcdSV) &
+ * (unun - G1snSV(ikl, isn) / G1_dSV)) &
+ + (1.-Sph_OK) * (-G1snSV(ikl, isn) * DDcdSV / G1_dSV &
+ + (unun + G1snSV(ikl, isn) / G1_dSV) &
+ * (G2snSV(ikl, isn) * DScdSV / G1_dSV &
+ + (unun - G2snSV(ikl, isn) / G1_dSV) &
+ * DFcdSV)))
+ SnOpSV(ikl, isn) = max(zero, SnOpSV(ikl, isn))
+ enddo
+ enddo
+
+ ! +--Snow/Ice Albedo
+ ! + ===============
+
+ ! +--Snow Age (Influence on Albedo)
+ ! + ------------------------------
+
+ ! snow age = date !XF 12/07/2019
+
+ !c #AG jjtime = jhurGE*3600+minuGE*60+jsecGE
+ !c #AG if (iabs(mod(jjtime,86400)).lt.dt__SV) then
+ !c #AG do isn=1,nsno
+ !c #AG do ikl=1,klonv
+ !c #AG agsnSV(ikl,isn) = agsnSV(ikl,isn) + 1.
+ !c #AG. + max(zero,DH_dSV(ivgtSV(ikl))-DH_dSV(4)) ! High Vegetation
+ !C + ! Impurities
+ !C +... CAUTION: crude parameterization
+ !C + ^^^^^^^
+ !c #AG end do
+ !c #AG end do
+ !c #AG end if
+
+ ! +--Uppermost effective Snow Layer
+ ! + ------------------------------
+
+ do ikl = 1, klonv
+
+ isn = max(iun, isnoSV(ikl))
+
+ SignRo = sign(unun, rocdSV - ro__SV(ikl, isn))
+ SnowOK = max(zero, SignRo) ! Ice Density Threshold
+
+ OpSqrt = sqrt(SnOpSV(ikl, isn))
+
+ !CA +--Correction of snow albedo for Antarctica/Greenland
+ !CA --------------------------------------------------
+ albCor = 1.
+#if(GL)
+ albCor = 1.0075
+#endif
+#if(AC)
+ albCor = 1.0075
+#endif
+
+ albSn1 = 0.96 - 1.580 * OpSqrt
+ albSn1 = max(albSn1, AlbMin)
+
+ albSn1 = max(albSn1, zero)
+ albSn1 = min(albSn1 * albCor, unun)
+
+ albSn2 = 0.95 - 15.40 * OpSqrt
+ albSn2 = max(albSn2, zero)
+ albSn2 = min(albSn2 * albCor, unun)
+
+ doptic = min(SnOpSV(ikl, isn), doptmx)
+ albSn3 = 346.3 * doptic - 32.31 * OpSqrt + 0.88
+ albSn3 = max(albSn3, zero)
+ albSn3 = min(albSn3 * albCor, unun)
+
+#if(GL)
+ ! snow albedo corection if wetsnow
+ albSn1 = albSn1 * max(0.9,(1.-2.5 * eta_SV(ikl, isn)))
+ albSn2 = albSn2 * max(0.9,(1.-2.5 * eta_SV(ikl, isn)))
+ albSn3 = albSn3 * max(0.9,(1.-2.5 * eta_SV(ikl, isn)))
+#endif
+
+ albSno = So1dSV * albSn1 &
+ + So2dSV * albSn2 &
+ + So3dSV * albSn3
+
+ !XF
+ minalb = (aI2dSV + (aI3dSV - aI2dSV) &
+ * (ro__SV(ikl, isn) - ro_Ice) / (roSdSV - ro_Ice))
+ minalb = min(aI3dSV, max(aI2dSV, minalb)) ! pure/firn albedo
+
+ SnowOK = SnowOK * max(zero, sign(unun, albSno - minalb))
+ albSn1 = SnowOK * albSn1 + (1.0 - SnowOK) * max(albSno, minalb)
+ albSn2 = SnowOK * albSn2 + (1.0 - SnowOK) * max(albSno, minalb)
+ albSn3 = SnowOK * albSn3 + (1.0 - SnowOK) * max(albSno, minalb)
+
+ ! + ro < roSdSV | min al > aI3dSV
+ ! + roSdSV < ro < rocdSV | aI2dSV < min al < aI3dSV (fct of density)
+
+ ! +--Snow/Ice Pack Thickness
+ ! + -----------------------
+
+ isn = max(min(isnoSV(ikl), ispiSV(ikl)), 0)
+ Snow_H = zzsnsv(ikl, isnoSV(ikl)) - zzsnsv(ikl, isn)
+ SIce_H = zzsnsv(ikl, isnoSV(ikl))
+ SnownH = Snow_H / HSnoSV
+ SnownH = min(unun, SnownH)
+ SIcenH = SIce_H / (HIceSV &
+ + max(zero, Z0mdSV(ivgtSV(ikl)) &
+ - Z0mdSV(4)))
+ SIcenH = min(unun, SIcenH)
+
+ ! + The value of SnownH is set to 1 in case of ice lenses above
+ ! + 1m of dry snow (ro<600kg/m3) for using CROCUS albedo
+
+ ! ro_ave = 0.
+ ! dz_ave = 0.
+ ! SnowOK = 1.
+ ! do isn = isnoSV(ikl),1,-1
+ ! ro_ave = ro_ave + ro__SV(ikl,isn) * dzsnSV(ikl,isn) * SnowOK
+ ! dz_ave = dz_ave + dzsnSV(ikl,isn) * SnowOK
+ ! SnowOK = max(zero,sign(unun,1.-dz_ave))
+ ! end do
+
+ ! ro_ave = ro_ave / max(dz_ave,epsi)
+ ! SnowOK = max(zero,sign(unun,600.-ro_ave))
+ ! SnownH = SnowOK + SnownH * (1. - SnowOK)
+
+ ! +--Integrated Snow/Ice Albedo: Case of Water on Bare Ice
+ ! + -----------------------------------------------------
+
+ isn = max(min(isnoSV(ikl), ispiSV(ikl)), 0)
+ !
+ ! 0 <=> freezing
+ ! 1 <=> isn=isnoSV
+ albWIc = aI1dSV - (aI1dSV - aI2dSV) &
+ * exp(-(rusnSV(ikl) &
+ * (1.-SWS_SV(ikl) &
+ * (1 - min(1, iabs(isn - isnoSV(ikl))))) &
+ / ru_dSV)**0.50)
+ ! albWIc = max(aI1dSV,min(aI2dSV,albWIc+slopSV(ikl)* &
+ ! min(5.,max(1.,dx/10000.))))
+
+ SignRo = sign(unun, ro_Ice - 5.-ro__SV(ikl, isn)) ! RoSN<920kg/m3
+ SnowOK = max(zero, SignRo)
+
+ albWIc = (1.-SnowOK) * albWIc + SnowOK &
+ * (aI2dSV + (aI3dSV - aI2dSV) &
+ * (ro__SV(ikl, isn) - ro_Ice) / (roSdSV - ro_Ice))
+
+ ! + rocdSV < ro < ro_ice | aI2dSV< al <aI3dSV (fct of density)
+ ! + ro > ro_ice | aI1dSV< al <aI2dSV (fct of superficial water content
+
+ ! +--Integrated Snow/Ice Albedo
+ ! + -------------------------------
+
+ a_SII1 = albWIc + (albSn1 - albWIc) * SnownH
+ a_SII1 = min(a_SII1, albSn1)
+
+ a_SII2 = albWIc + (albSn2 - albWIc) * SnownH
+ a_SII2 = min(a_SII2, albSn2)
+
+ a_SII3 = albWIc + (albSn3 - albWIc) * SnownH
+ a_SII3 = min(a_SII3, albSn3)
+
+ !c #AG agesno = min(agsnSV(ikl,isn) ,AgeMax)
+ !c #AG a_SII1 = a_SII1 -0.175*agesno/AgeMax
+ ! +... Impurities: Col de Porte Parameter.
+
+ ! Zenith Angle Correction (Segal et al., 1991, JAS 48, p.1025)
+ ! ----------------------- (Wiscombe & Warren, dec1980, JAS , p.2723)
+ ! (Warren, 1982, RG , p. 81)
+ ! --------------------------------------------
+
+ dalbed = 0.0
+ csegal = max(czemax, coszSV(ikl))
+#if(cz)
+ dalbeS = ((bsegal + unun) / (unun + 2.0 * bsegal * csegal) &
+ - unun) * 0.32 &
+ / bsegal
+ dalbeS = max(dalbeS, zero)
+ dalbed = dalbeS * min(1, isnoSV(ikl))
+#endif
+
+ dalbeW = (0.64 - csegal) * 0.0625 ! Warren 1982, RevGeo, fig.12b
+ ! ! 0.0625 = 5% * 1/0.8, p.81
+ ! ! 0.64 = cos(50)
+ dalbed = dalbeW * min(1, isnoSV(ikl))
+
+ ! +--Col de Porte Integrated Snow/Ice Albedo
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(cp)
+ if(ColPrt .and. TotSol > 0.) then
+ albSII = (((Dr_1SN * a_SII1 + Dr_2SN * a_SII2 + Dr_3SN * a_SII3) &
+ + dalbed) &
+ * DirSol &
+ + (Df_1SN * a_SII1 + Df_2SN * a_SII2 + Df_3SN * a_SII3) &
+ * DifSol * (1.-cld_SV(ikl)) &
+ + (Dfc1SN * a_SII1 + Dfc2SN * a_SII2 + Dfc3SN * a_SII3) &
+ * DifSol * cld_SV(ikl)) &
+ / TotSol
+ ! +--Elsewhere Integrated Snow/Ice Albedo
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else
+#endif
+ albSII = So1dSV * a_SII1 &
+ + So2dSV * a_SII2 &
+ + So3dSV * a_SII3
+#if(cp)
+ endif
+#endif
+
+ ! +--Integrated Snow/Ice/Soil Albedo
+ ! + -------------------------------
+
+ alb1sv(ikl) = albssv(ikl) + (a_SII1 - albssv(ikl)) * SIcenH
+ alb1sv(ikl) = min(alb1sv(ikl), a_SII1)
+
+ alb2sv(ikl) = albssv(ikl) + (a_SII2 - albssv(ikl)) * SIcenH
+ alb2sv(ikl) = min(alb2sv(ikl), a_SII2)
+
+ alb3sv(ikl) = albssv(ikl) + (a_SII3 - albssv(ikl)) * SIcenH
+ alb3sv(ikl) = min(alb3sv(ikl), a_SII3)
+
+ albisv(ikl) = albssv(ikl) + (albSII - albssv(ikl)) * SIcenH
+ albisv(ikl) = min(albisv(ikl), albSII)
+
+ ! +--Integrated Snow/Ice/Soil Albedo: Clouds Correction! Greuell & all., 1994
+ ! + Glob. &t Planet.Change (9):91-114
+#if(cp)
+ if(.not. ColPrt) then
+#endif
+ alb1sv(ikl) = alb1sv(ikl) + 0.02 * (cld_SV(ikl) - 0.5) * SIcenH &
+ + dalbed * (1.-cld_SV(ikl))
+ alb2sv(ikl) = alb2sv(ikl) + 0.02 * (cld_SV(ikl) - 0.5) * SIcenH &
+ + dalbed * (1.-cld_SV(ikl))
+ alb3sv(ikl) = alb3sv(ikl) + 0.02 * (cld_SV(ikl) - 0.5) * SIcenH &
+ + dalbed * (1.-cld_SV(ikl))
+ albisv(ikl) = albisv(ikl) + 0.02 * (cld_SV(ikl) - 0.5) * SIcenH &
+ + dalbed * (1.-cld_SV(ikl))
+#if(cp)
+ endif
+#endif
+
+ ! +--Integrated Snow/Ice/Soil Albedo: Minimum snow albedo = aI1dSV
+ ! + -------------------------------------------------------------
+
+ albedo_old = albisv(ikl)
+ albisv(ikl) = max(albisv(ikl), aI1dSV * SIcenH &
+ + albssv(ikl) * (1.0 - SIcenH))
+ ! 33 %
+ alb1sv(ikl) = alb1sv(ikl) - 1.0 / 3.0 &
+ * (albedo_old - albisv(ikl)) / So1dSV
+ ! 33 %
+ alb2sv(ikl) = alb2sv(ikl) - 1.0 / 3.0 &
+ * (albedo_old - albisv(ikl)) / So2dSV
+ ! 33 %
+ alb3sv(ikl) = alb3sv(ikl) - 1.0 / 3.0 &
+ * (albedo_old - albisv(ikl)) / So3dSV
+
+ ! +--Integrated Snow/Ice/Soil Albedo: Maximum albedo = 95%
+ ! + -----------------------------------------------------
+
+ albedo_old = albisv(ikl)
+ albisv(ikl) = min(albisv(ikl), 0.95)
+ ! 33 %
+ alb1sv(ikl) = alb1sv(ikl) - 1.0 / 3.0 &
+ * (albedo_old - albisv(ikl)) / So1dSV
+ ! 33 %
+ alb2sv(ikl) = alb2sv(ikl) - 1.0 / 3.0 &
+ * (albedo_old - albisv(ikl)) / So2dSV
+ ! 33 %
+ alb3sv(ikl) = alb3sv(ikl) - 1.0 / 3.0 &
+ * (albedo_old - albisv(ikl)) / So3dSV
+
+#if(AO)
+ ! Sea Ice/snow permanent-interractive prescription from Nemo
+ ! AO_CK 20/02/2020
+ ! No check if coupling update since MAR and NEMO albedo are too different
+ ! and since MAR albedo is computed on properties that are not in NEMO
+ ! prescription for each time step with NEMO values
+ if(LSmask(ikl) == 0 .and. coupling_ao == .true.) then
+ if(AOmask(ikl) == 0) then
+ albisv(ikl) = (1.-AOmask(ikl)) * albAOsisv(ikl) &
+ + (AOmask(ikl) * albisv(ikl))
+ alb1sv(ikl) = (1.-AOmask(ikl)) * albAOsisv(ikl) &
+ + (AOmask(ikl) * alb1sv(ikl))
+ alb2sv(ikl) = (1.-AOmask(ikl)) * albAOsisv(ikl) &
+ + (AOmask(ikl) * alb2sv(ikl))
+ alb3sv(ikl) = (1.-AOmask(ikl)) * albAOsisv(ikl) &
+ + (AOmask(ikl) * alb3sv(ikl))
+ endif
+ endif
+#endif
+
+ alb1sv(ikl) = min(max(zero, alb1sv(ikl)), albmax)
+ alb2sv(ikl) = min(max(zero, alb2sv(ikl)), albmax)
+ alb3sv(ikl) = min(max(zero, alb3sv(ikl)), albmax)
+
+ enddo
+
+ ! +--Extinction Coefficient: Exponential Factor
+ ! + ==========================================
+
+ do ikl = 1, klonv
+ sExt_1(ikl) = 1.
+ sExt_2(ikl) = 1.
+ sExt_3(ikl) = 1.
+ sEX_sv(ikl, nsno + 1) = 1.
+
+ coalb1(ikl) = (1.-alb1sv(ikl)) * So1dSV
+ coalb2(ikl) = (1.-alb2sv(ikl)) * So2dSV
+ coalb3(ikl) = (1.-alb3sv(ikl)) * So3dSV
+ coalbm = coalb1(ikl) + coalb2(ikl) + coalb3(ikl)
+ coalb1(ikl) = coalb1(ikl) / coalbm
+ coalb2(ikl) = coalb2(ikl) / coalbm
+ coalb3(ikl) = coalb3(ikl) / coalbm
+ enddo
+
+ !XF
+
+ do isn = nsno, 1, -1
+ do ikl = 1, klonv
+ sEX_sv(ikl, isn) = 1.0
+ ! !sEX_sv(ikl,isn) = 0.95 ! if MAR is too warm in summer
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ do isn = max(1, isnoSV(ikl)), 1, -1
+
+ SignRo = sign(unun, rocdSV - ro__SV(ikl, isn))
+ SnowOK = max(zero, SignRo) ! Ice Density Threshold
+
+ RoFrez = 1.e-3 * ro__SV(ikl, isn) * (1.0 - eta_SV(ikl, isn))
+
+ OpSqrt = sqrt(max(epsi, SnOpSV(ikl, isn)))
+ exarg1 = SnowOK * 1.e2 * max(sbeta1 * RoFrez / OpSqrt, sbeta2) &
+ + (1.0 - SnowOK) * sbeta5
+ exarg2 = SnowOK * 1.e2 * max(sbeta3 * RoFrez / OpSqrt, sbeta4) &
+ + (1.0 - SnowOK) * sbeta5
+ exarg3 = SnowOK * 1.e2 * sbeta5 &
+ + (1.0 - SnowOK) * sbeta5
+
+#if(cp)
+ ! +--Col de Porte Snow Extinction Coefficient
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ColPrt .and. TotSol > 0.) then
+ exarg1 = exarg1 * (Dr_1SN * DirSol &
+ + Df_1SN * DifSol * (1.-cld_SV(ikl)) &
+ + Dfc1SN * DifSol * cld_SV(ikl)) &
+ / (Dr_1SN * TotSol)
+ exarg2 = exarg2 * (Dr_2SN * DirSol &
+ + Df_2SN * DifSol * (1.-cld_SV(ikl)) &
+ + Dfc2SN * DifSol * cld_SV(ikl)) &
+ / (Dr_2SN * TotSol)
+ exarg3 = exarg3 * (Dr_3SN * DirSol &
+ + Df_3SN * DifSol * (1.-cld_SV(ikl)) &
+ + Dfc3SN * DifSol * cld_SV(ikl)) &
+ / (Dr_3SN * TotSol)
+ endif
+#endif
+
+ ! +--Integrated Extinction of Solar Irradiance (Normalized Value)
+ ! + ============================================================
+
+ sExt_1(ikl) = sExt_1(ikl) &
+ * exp(min(0.0, -exarg1 * dzsnSV(ikl, isn)))
+ sign_0 = sign(unun, eps9 - sExt_1(ikl))
+ sExt_0 = max(zero, sign_0) * sExt_1(ikl)
+ sExt_1(ikl) = sExt_1(ikl) - sExt_0
+
+ sExt_2(ikl) = sExt_2(ikl) &
+ * exp(min(0.0, -exarg2 * dzsnSV(ikl, isn)))
+ sign_0 = sign(unun, eps9 - sExt_2(ikl))
+ sExt_0 = max(zero, sign_0) * sExt_2(ikl)
+ sExt_2(ikl) = sExt_2(ikl) - sExt_0
+
+ sExt_3(ikl) = sExt_3(ikl) &
+ * exp(min(0.0, -exarg3 * dzsnSV(ikl, isn)))
+ sign_0 = sign(unun, eps9 - sExt_3(ikl))
+ sExt_0 = max(zero, sign_0) * sExt_3(ikl)
+ sExt_3(ikl) = sExt_3(ikl) - sExt_0
+
+ sEX_sv(ikl, isn) = coalb1(ikl) * sExt_1(ikl) &
+ + coalb2(ikl) * sExt_2(ikl) &
+ + coalb3(ikl) * sExt_3(ikl)
+ enddo
+ enddo
+
+ do isn = 0, -nsol, -1
+ do ikl = 1, klonv
+ sEX_sv(ikl, isn) = 0.0
+ enddo
+ enddo
+
+#if(va)
+ ! +--Albedo: IO
+ ! + ==========
+ if(.not. aw_opn) then
+ aw_opn = .true.
+ open(unit=46, status='unknown', file='SnOptP____.va')
+ rewind(46)
+ endif
+ ikl = 1
+ write(46, 460) daHost
+460 format('---------------------------------+----+', &
+ '-------+-------+-------+-------+-------+-------+', &
+ '-------+-------+-------+', &
+ /, 'Snow/Ice Pack ', a18, ' | |', &
+ ' z [m] |0.3/0.8|0.8/1.5|1.5/2.8| Full |Opt[mm]|', &
+ ' G1 | G2 | ro |', &
+ /, '---------------------------------+----+', &
+ '-------+-------+-------+-------+-------+-------+', &
+ '-------+-------+-------+')
+ ! ______________________________________________________________
+ write(46, 461) SIce_H, &
+ alb1sv(ikl), alb2sv(ikl), alb3sv(ikl), &
+ albisv(ikl)
+461 format('Integrated Snow/Ice/Soil Albedo |', &
+ 3x, ' |', f6.3, ' |', 4(f6.3, ' |'), 6x, ' |', &
+ 3(6x, ' |'))
+ ! ______________________________________________________________
+ write(46, 462) ispiSV(ikl), a_SII1, a_SII2, a_SII3, albSII
+462 format('Integrated Snow/Ice Albedo |', &
+ i3, ' |', 6x, ' |', 4(f6.3, ' |'), 6x, ' |', &
+ 3(6x, ' |'))
+ ! ______________________________________________________________
+ write(46, 463) rusnSV(ikl), albWIc, &
+ SWS_SV(ikl)
+463 format('Integrated Water/Bare Ice Albedo |', &
+ 3x, ' |', f6.3, 'w|', 3(6x, ' |'), &
+ f6.3, ' |', f6.3, ' |', &
+ 3(6x, ' |'))
+ ! ______________________________________________________________
+ write(46, 464) LiceOK, a_SnI1, a_SnI2, a_SnI3, albSnI
+464 format('Integrated Snow/Ice Lense Albedo |', &
+ f4.0, '|', 6x, ' |', 4(f6.3, ' |'), 6x, ' |', &
+ 3(6x, ' |'))
+ ! ______________________________________________________________
+ write(46, 465) isn1, zzsnsv(ikl, isn1), &
+ albIc1, albIc2, albIc3, albIce, &
+ 1.e3 * SnOpSV(ikl, max(iun, isnoSV(ikl) - iun)), &
+ G1snSV(ikl, max(iun, isnoSV(ikl) - iun)), &
+ G2snSV(ikl, max(iun, isnoSV(ikl) - iun)), &
+ ro__SV(ikl, max(iun, isnoSV(ikl) - iun)) &
+ * (1.-eta_SV(ikl, max(iun, isnoSV(ikl) - iun)))
+465 format('Surficial Ice Lense |', &
+ i3, ' |',(f6.3, 'i|'), 4(f6.3, ' |'), f6.3, ' |', &
+ 3(f6.1, ' |'))
+ ! ______________________________________________________________
+ write(46, 466) isnoSV(ikl), zzsnsv(ikl, isnoSV(ikl)), &
+ albSn1, albSn2, albSn3, albSno, &
+ 1.e3 * SnOpSV(ikl, isnoSV(ikl)), &
+ G1snSV(ikl, isnoSV(ikl)), &
+ G2snSV(ikl, isnoSV(ikl)), &
+ ro__SV(ikl, isnoSV(ikl)) &
+ * (1.-eta_SV(ikl, isnoSV(ikl)))
+466 format('Uppermost Effective Snow Layer |', &
+ i3, ' |',(f6.3, '*|'), 4(f6.3, ' |'), f6.3, ' |', &
+ 3(f6.1, ' |'))
+#endif
+
+ return
+end
diff --git a/MAR/code_mar/sisvat_sno_filtering.f90 b/MAR/code_mar/sisvat_sno_filtering.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e1d2a0c98b44a53b2cd38f0e12b919140588c8c9
--- /dev/null
+++ b/MAR/code_mar/sisvat_sno_filtering.f90
@@ -0,0 +1,214 @@
+#include "MAR_pp.def"
+subroutine sno_filtering()
+ ! +------------------------------------------------------------------------+
+ ! | SISVAT 25-04-2020 MAR |
+ ! | |
+ ! | subroutine snow_filtering |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_sv
+ use mar_sl
+ use mar_hy
+ use marssn
+ use mardsv
+ use mar_tv
+
+ implicit none
+
+ real weight ! weight for the central pixel
+
+ integer i, j, k, m
+ integer l, kk, n, nb
+ real g2_ave, ro_ave, nbr1, nbr2, nbr3, nbr4
+ real al_ave, ussave, corr, ww, dz_ave
+ real ratio(mx, my, mw), g2_new(mx, my, mw), ussnew(mx, my, mw)
+ integer correction(mx, my, mw)
+ real(kind=8) sumin, sumou
+
+ logical density_filtering
+
+ density_filtering = .true.
+
+ weight = 4.*max(1., min(10., sqrt(dx / 1000)))
+#if(BS)
+ weight = 12.*max(1., min(10., sqrt(dx / 1000)))
+#endif
+
+!$OMP PARALLEL do &
+!$OMP private(i,j,k,l,n,m,ww,nbr1,nbr2,nbr3,ro_ave,g2_ave,al_ave,ussave, &
+!$OMP dz_ave,corr,nbr4) &
+!$OMP schedule(dynamic)
+ do j = 7, my - 6 ! only the interesting domain
+ do i = 7, mx - 6
+
+ ! ! increase the melt of snowpack when some sub pixels are snow free.
+ do n = 1, mw
+ do m = 1, mw
+ if(n /= m) then
+ if(nssSNo(i, j, m) == 0 .and. nssSNo(i, j, n) > 1 .and. &
+ ivegTV(i, j, m) > 0 .and. ivegTV(i, j, n) > 0 .and. &
+ ifraTV(i, j, m) > 0 .and. ifraTV(i, j, n) > 0 .and. &
+ tairDY(i, j, mz) > 275.15) then
+
+ tisSNo(i, j, n, nssSNo(i, j, n)) = 273.15 &
+ + max(0., min(tsrfSL(i, j, m), tairDY(i, j, mz) - 273.15) / 20.)
+
+ tisSNo(i, j, n, nssSNo(i, j, n)) = max(273.15, &
+ min(tisSNo(i, j, n, nssSNo(i, j, n)), 274.15))
+
+ endif
+ endif
+ enddo
+
+ if(SLsrfl(i, j, n) <= 0) then
+ nssSNo(i, j, n) = 0
+ do k = 1, nsno
+ dzsSNo(i, j, n, k) = 0.
+ enddo
+ endif
+ enddo
+
+ do n = 1, min(mw, 2) ! sea ice and ice sheet only
+
+ ratio(i, j, n) = 1.
+ correction(i, j, n) = 0.
+ !c#BS ussnew(i,j,n) = uss_HY(i,j)
+ ! only in the accumulation zone
+ if(nssSNo(i, j, n) > 3 .and. &
+ ifraTV(i, j, n) > 0 .and. &
+ ivegTV(i, j, n) <= 0. .and. &
+ rosSNo(i, j, n, max(1, nssSNo(i, j, n))) < 700. .and. &
+ dzsSNo(i, j, n, max(1, nssSNo(i, j, n))) > 0.001) then
+
+ nbr1 = 0; nbr2 = 0; nbr3 = 0; nbr4 = 0
+ ro_ave = 0; g2_ave = 0; al_ave = 0; dz_ave = 0
+ !c#BS ussave=0
+
+ ! ! only in the accumulation zone
+ do k = -1, 1; do l = -1, 1
+ if(nssSNo(i + k, j + l, n) > 3 .and. &
+ ifraTV(i + k, j + l, n) > 0 .and. &
+ ivegTV(i + k, j + l, n) <= 0 .and. &
+ rosSNo(i + k, j + l, n, max(1, nssSNo(i + k, j + l, n))) < 700. .and. &
+ dzsSNo(i + k, j + l, n, max(1, nssSNo(i + k, j + l, n))) > 0.001 .and. &
+ tisSNo(i + k, j + l, n, max(1, nssSNo(i + k, j + l, n))) < 273. .and. &
+ tisSNo(i + k, j + l, n, max(1, nssSNo(i + k, j + l, n))) > 263.) then
+
+ ww = 1
+ if(k == 0 .or. l == 0) ww = 2
+ if(k == 0 .and. l == 0) ww = weight
+
+ dz_ave = dz_ave + dzsSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+
+ ro_ave = ro_ave + rosSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+
+ al_ave = al_ave + albxSL(i + k, j + l, n) * ww
+ !c#BS ussave = ussave + uss_HY(i,j) *min(12.,ww)
+
+ nbr1 = nbr1 + 1
+ nbr2 = nbr2 + ww
+ !c#BS nbr4 = nbr4+min(12.,ww)
+
+ if(g1sSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) >= 0) then
+ g2_ave = g2_ave + g2sSNo(i + k, j + l, n, nssSNo(i + k, j + l, n)) * ww
+ nbr3 = nbr3 + ww
+ endif
+ endif
+ enddo;
+ enddo
+
+ al_ave = al_ave / max(1., nbr2)
+ ro_ave = ro_ave / max(1., nbr2)
+ dz_ave = dz_ave / max(1., nbr2)
+ g2_ave = g2_ave / max(1., nbr3)
+ !c#BS ussave = ussave / max(1.,nbr4)
+
+ if(dz_ave >= dzsSNo(i, j, n, nssSNo(i, j, n))) then
+ corr = dzsSNo(i, j, n, nssSNo(i, j, n)) / dz_ave
+ else
+ corr = dz_ave / dzsSNo(i, j, n, nssSNo(i, j, n))
+ endif
+
+ corr = corr * (1.- &
+ (700.-rosSNo(i, j, n, nssSNo(i, j, n)))**2 / &
+ (700.-300.))**2
+ corr = max(0.1, min(0.9, corr))
+
+ ro_ave = ro_ave * corr &
+ + rosSNo(i, j, n, nssSNo(i, j, n)) * (1.-corr)
+
+ ratio(i, j, n) = ro_ave / (rosSNo(i, j, n, nssSNo(i, j, n)))
+ ratio(i, j, n) = max(0.9, min(1.1, ratio(i, j, n))) ! max 10 %
+
+ corr = ratio(i, j, n) ! backup
+
+ if(tisSNo(i, j, n, nssSNo(i, j, n)) > 273.14 .or. &
+ tairdy(i, j, mz) > 275.14) then
+ ratio(i, j, n) = 1
+ endif
+
+ g2_new(i, j, n) = g2sSNo(i, j, n, nssSNo(i, j, n))
+
+ ! ! problem of albedo in the accumulation zone
+ if(albxSL(i, j, n) < al_ave * 0.99 .and. &
+ g1sSNo(i, j, n, nssSNo(i, j, n)) > 0 .and. &
+ albxSL(i, j, n) < 0.72) then
+
+ if(nbr3 > 0) g2_new(i, j, n) = min(g2_new(i, j, n), g2_ave)
+ ratio(i, j, n) = min(1., corr)
+ if(nbr1 >= 6) nbr1 = 9
+ endif
+
+ ! refreezing of aquifer in winter!!
+ ! if(tairdy(i, j, mz)<253.15) then
+ ! tisSNo(i, j, n, 1) = min(tisSNo(i, j, n, 1), 273.145)
+ ! end if
+
+ if(nbr1 >= 8) then
+ correction(i, j, n) = 1
+ !c#BS ussnew(i,j,n) =ussave
+ endif
+
+ endif
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+ !c#BS sumin=0. ; sumou=0.
+
+ do j = 7, my - 6
+ do i = 7, mx - 6
+
+ !c#BS sumin=sumin+uss_hy(i,j)
+ !c#BS sumou=sumou+ussnew(i,j,1)
+
+ do n = 1, 2
+ if(correction(i, j, n) == 1) then
+ g2sSNo(i, j, n, nssSNo(i, j, n)) = g2_new(i, j, n)
+ if(density_filtering) then
+ dzsSNo(i, j, n, nssSNo(i, j, n)) = dzsSNo(i, j, n, nssSNo(i, j, n)) &
+ / ratio(i, j, n)
+ rosSNo(i, j, n, nssSNo(i, j, n)) = rosSNo(i, j, n, nssSNo(i, j, n)) &
+ * ratio(i, j, n)
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ !c#BS if(abs(sumin)>epsi.and.abs(sumou)>epsi) then
+ !c#BS do j = 7,my-6
+ !c#BS do i = 7,mx-6
+ !c#BS uss_HY(i,j)=ussnew(i,j,1)*sumin/sumou
+ !c#BS end do
+ !c#BS end do
+ !c#BS end if
+
+endsubroutine sno_filtering
diff --git a/MAR/code_mar/sisvat_tso.f90 b/MAR/code_mar/sisvat_tso.f90
new file mode 100644
index 0000000000000000000000000000000000000000..45eb9d9c81f1b2012cf7068285d5756a850c6f9b
--- /dev/null
+++ b/MAR/code_mar/sisvat_tso.f90
@@ -0,0 +1,759 @@
+#include "MAR_pp.def"
+subroutine SISVAT_TSo(ETSo_0, ETSo_1, ETSo_d)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_TSo 16-06-2021 MAR |
+ ! | subroutine SISVAT_TSo computes the Soil/Snow Energy Balance |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: isotSV = 0,...,11: Soil Type |
+ ! | ^^^^^ 0: Water, Solid or Liquid |
+ ! | isnoSV = total Nb of Ice/Snow Layers |
+ ! | dQa_SV = Limitation of Water Vapor Turbulent Flux |
+ ! | |
+ ! | INPUT: sol_SV : Downward Solar Radiation [W/m2] |
+ ! | ^^^^^ IRd_SV : Surface Downward Longwave Radiation [W/m2] |
+ ! | za__SV : SBL Top Height [m] |
+ ! | VV__SV : SBL Top Wind Speed [m/s] |
+ ! | TaT_SV : SBL Top Temperature [K] |
+ ! | rhT_SV : SBL Top Air Density [kg/m3] |
+ ! | QaT_SV : SBL Top Specific Humidity [kg/kg] |
+ ! | LSdzsv : Vertical Discretization Factor [-] |
+ ! | = 1. Soil |
+ ! | = 1000. Ocean |
+ ! | dzsnSV : Snow Layer Thickness [m] |
+ ! | ro__SV : Snow/Soil Volumic Mass [kg/m3] |
+ ! | eta_SV : Soil Water Content [m3/m3] |
+ ! | dt__SV : Time Step [s] |
+ ! | |
+ ! | SoSosv : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
+ ! | IRv_sv : Vegetation IR Radiation [W/m2] |
+ ! | tau_sv : Fraction of Radiation transmitted by Canopy [-] |
+ ! | Evg_sv : Soil+Vegetation Emissivity [-] |
+ ! | Eso_sv : Soil+Snow Emissivity [-] |
+ ! | rah_sv : Aerodynamic Resistance for Heat [s/m] |
+ ! | Lx_H2O : Latent Heat of Vaporization/Sublimation [J/kg] |
+ ! | Sigmsv : Canopy Ventilation Factor [-] |
+ ! | sEX_sv : Verticaly Integrated Extinction Coefficient [-] |
+ ! | |
+ ! | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+ ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] |
+ ! | ^^^^^^ |
+ ! | |
+ ! | OUTPUT: IRs_SV : Soil IR Radiation [W/m2] |
+ ! | ^^^^^^ HSs_sv : Sensible Heat Flux [W/m2] |
+ ! | HLs_sv : Latent Heat Flux [W/m2] |
+ ! | ETSo_0 : Snow/Soil Energy Power, before Forcing [W/m2] |
+ ! | ETSo_1 : Snow/Soil Energy Power, after Forcing [W/m2] |
+ ! | ETSo_d : Snow/Soil Energy Power Forcing [W/m2] |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | |
+ ! | METHOD: NO Skin Surface Temperature |
+ ! | ^^^^^^ Semi-Implicit Crank Nicholson Scheme |
+ ! | |
+ ! | # OPTIONS: #E0: Energy Budget Verification |
+ ! | # ^^^^^^^ #kd: KDsvat Option:NO Flux Limitor on HL |
+ ! | # #KD: KDsvat Option:Explicit Formulation of HL |
+ ! | # #NC: OUTPUT for Stand Alone NetCDF File |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ ! +--OUTPUT
+ ! + ------
+ ! Soil/Snow Power, before Forcing
+ real ETSo_0(klonv)
+ ! Soil/Snow Power, after Forcing
+ real ETSo_1(klonv)
+ ! Soil/Snow Power, Forcing
+ real ETSo_d(klonv)
+
+ ! +--Internal Variables
+ ! + ==================
+
+ real zt(klonv), ti(klonv), ww
+ integer ikl, isl, jsl, ist, izt(klonv)
+ ! ist__s, ist__w : Soil/Water Body Identifier
+ integer ist__s, ist__w
+ ! islsgn : Soil/Snow Surfac.Identifier
+ integer islsgn
+ ! eps__3 : Arbitrary Low Number
+ real eps__3
+ ! etaMid, psiMid : Layer Interface's Humidity
+ real etaMid, psiMid
+ ! mu_eta : Soil thermal Conductivity
+ real mu_eta
+ ! mu_exp : arg Soil thermal Conductivity
+ real mu_exp
+ ! mu_min : Min Soil thermal Conductivity
+ real mu_min
+ ! mu_max : Max Soil thermal Conductivity
+ real mu_max
+ ! mu_sno, mu_aux : Snow thermal Conductivity
+ real mu_sno(klonv), mu_aux
+ ! mu__dz : mu_(eta,sno) / dz
+ real mu__dz(klonv, -nsol:nsno + 1)
+ ! dtC_sv : dt / C
+ real dtC_sv(klonv, -nsol:nsno)
+ ! IRs__D : UpwardIR Previous Iter.Contr.
+ real IRs__D(klonv)
+ ! dIRsdT : UpwardIR T Derivat.
+ real dIRsdT(klonv)
+ ! f_HSHL : Factor common to HS and HL
+ real f_HSHL(klonv)
+ ! dRidTs : d(Rib)/d(Ts)
+ real dRidTs(klonv)
+ ! HS___D : Sensible Heat Flux Atm.Contr.
+ real HS___D(klonv)
+ ! f___HL :
+ real f___HL(klonv)
+ ! HL___D : Latent Heat Flux Atm.Contr.
+ real HL___D(klonv)
+ ! TSurf0 : Previous Surface Temperature
+ real TSurf0(klonv), dTSurf
+ ! qsatsg : Soil Saturat. Spec. Humidity
+ real qsatsg(klonv)
+ ! dqs_dT : d(qsatsg)/dTv
+ real dqs_dT(klonv)
+ ! Psi : 1st Soil Layer Water Potential
+ real Psi(klonv)
+ ! RHuSol : Soil Surface Relative Humidity
+ real RHuSol(klonv)
+ ! etaSol : Soil Surface Humidity
+ real etaSol
+ ! Elem_A, Elem_C : Diagonal Coefficients
+ real Elem_A, Elem_C
+ ! Diag_A : A Diagonal
+ real Diag_A(klonv, -nsol:nsno)
+ ! Diag_B : B Diagonal
+ real Diag_B(klonv, -nsol:nsno)
+ ! Diag_C : C Diagonal
+ real Diag_C(klonv, -nsol:nsno)
+ ! Term_D : Independant Term
+ real Term_D(klonv, -nsol:nsno)
+ ! Aux__P : P Auxiliary Variable
+ real Aux__P(klonv, -nsol:nsno)
+ ! Aux__Q : Q Auxiliary Variable
+ real Aux__Q(klonv, -nsol:nsno)
+ ! Ts_Min, Ts_Max : Temperature Limits
+ real Ts_Min, Ts_Max
+ ! Exist0 : Existing Layer Switch
+ real Exist0
+ ! psat_wat, psat_ice, sp, dzVap0 : computation of qsat
+ real psat_wat, psat_ice, sp, dzVap0
+
+ ! nt_srf, it_srf, itEuBk : HL Surface Scheme
+ integer nt_srf, it_srf, itEuBk
+ ! nt_srf = 10 before
+ parameter(nt_srf=6)
+ real agpsrf, xgpsrf, dt_srf, dt_ver
+ real etaBAK(klonv)
+ real etaNEW(klonv)
+ real etEuBk(klonv)
+ real fac_dt(klonv), faceta(klonv)
+ real PsiArg(klonv), SHuSol(klonv)
+#if(NC)
+ ! +--OUTPUT for Stand Alone NetCDF File
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! Absorbed Solar Radiation
+ real SOsoKL(klonv)
+ ! Absorbed IR Radiation
+ real IRsoKL(klonv)
+ ! Absorbed Sensible Heat Flux
+ real HSsoKL(klonv)
+ ! Absorbed Latent Heat Flux
+ real HLsoKL(klonv)
+ ! Evaporation
+ real HLs_KL(klonv)
+ ! Transpiration
+ real HLv_KL(klonv)
+ common / DumpNC / SOsoKL, IRsoKL, HSsoKL, HLsoKL, HLs_KL, HLv_KL
+#endif
+
+ ! +--Internal DATA
+ ! + =============
+ ! eps__3 : Arbitrary Low Number
+ data eps__3/1.e-3/
+ ! mu_exp : Soil Thermal Conductivity
+ data mu_exp/-0.4343/
+ ! mu_min : Min Soil Thermal Conductivity
+ data mu_min/0.172/
+ ! mu_max : Max Soil Thermal Conductivity
+ data mu_max/2.000/
+ ! Ts_Min : Temperature Minimum
+ data Ts_Min/175./
+ ! Ts_Max : Temperature Acceptable Maximum including Snow Melt Energy
+ data Ts_Max/300./
+
+ ! +--Heat Conduction Coefficient (zero in the Layers over the highest one)
+ ! + ===========================
+ ! + ---------------- isl eta_SV, rho C (isl)
+ ! +
+ ! +--Soil ++++++++++++++++ etaMid, mu (isl)
+ ! + ----
+ ! + ---------------- isl-1 eta_SV, rho C (isl-1)
+ isl = -nsol
+ do ikl = 1, klonv
+ mu__dz(ikl, isl) = 0.
+ ! dt / (dz X rho C)
+ ! [s / (m.J/m3/K)]
+ dtC_sv(ikl, isl) = dtz_SV2(isl) * dt__SV &
+ / ((rocsSV(isotSV(ikl)) &
+ + rcwdSV * eta_SV(ikl, isl)) &
+ * LSdzsv(ikl))
+ enddo
+ do isl = -nsol + 1, 0
+ do ikl = 1, klonv
+ ! Soil Type
+ ist = isotSV(ikl)
+ ! 1 => Soil
+ ist__s = min(ist, 1)
+ ! 1 => Water Body
+ ist__w = 1 - ist__s
+ ! eta at layers
+ ! interface
+ ! LSdzsv implicit
+ etaMid = 0.5 * (dz_dSV(isl - 1) * eta_SV(ikl, isl - 1) &
+ + dz_dSV(isl) * eta_SV(ikl, isl)) &
+ / dzmiSV(isl)
+ etaMid = max(etaMid, epsi)
+ psiMid = psidSV(ist) &
+ * (etadSV(ist) / etaMid)**bCHdSV(ist)
+ ! Soil Thermal Conductivity DR97 eq.3.31
+ mu_eta = 3.82 * (psiMid)**mu_exp
+ mu_eta = min(max(mu_eta, mu_min), mu_max)
+ ! +
+ ! Water Bodies Correction
+ mu_eta = ist__s * mu_eta + ist__w * vK_dSV
+ ! +
+ mu__dz(ikl, isl) = mu_eta / (dzmiSV(isl) &
+ * LSdzsv(ikl))
+ ! dt / (dz X rho C)
+ dtC_sv(ikl, isl) = dtz_SV2(isl) * dt__SV &
+ / ((rocsSV(isotSV(ikl)) &
+ + rcwdSV * eta_SV(ikl, isl)) &
+ * LSdzsv(ikl))
+ enddo
+ enddo
+
+ ! +--Soil/Snow Interface
+ ! + -------------------
+
+ ! +--Soil Contribution
+ ! + ^^^^^^^^^^^^^^^^^
+ isl = 1
+ do ikl = 1, klonv
+ ist = isotSV(ikl) ! Soil Type
+ ist__s = min(ist, 1) ! 1 => Soil
+ ist__w = 1 - ist__s ! 1 => Water Body
+ psiMid = psidSV(ist) ! Snow => Saturation
+ mu_eta = 3.82 * (psiMid)**mu_exp ! Soil Thermal
+ mu_eta = min(max(mu_eta, mu_min), mu_max) ! Conductivity
+ ! + ! DR97 eq.3.31
+ mu_eta = ist__s * mu_eta + ist__w * vK_dSV ! Water Bodies
+
+ ! +--Snow Contribution
+ ! + ^^^^^^^^^^^^^^^^^
+ ! mu_sno : Snow Heat Conductivity Coefficient [Wm/K]
+ ! (Yen 1981, CRREL Rep., 81-10)
+ mu_sno(ikl) = CdidSV &
+ * (ro__SV(ikl, isl) / ro_Wat)**1.88
+ mu_sno(ikl) = max(epsi, mu_sno(ikl))
+
+ ! +--Combined Heat Conductivity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ mu__dz(ikl, isl) = 2./(dzsnSV(ikl, isl) / mu_sno(ikl) + LSdzsv(ikl) * dz_dSV(isl - 1) / mu_eta)
+
+ ! +--Inverted Heat Capacity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^
+ ! dt / (dz X rho C)
+ dtC_sv(ikl, isl) = dt__SV / max(epsi, dzsnSV(ikl, isl) * ro__SV(ikl, isl) * Cn_dSV)
+ enddo
+
+ ! +--Snow
+ ! + ----
+
+ do ikl = 1, klonv
+ do isl = 1, min(nsno, isnoSV(ikl) + 1)
+ ro__SV(ikl, isl) = &
+ ro__SV(ikl, isl) &
+ * max(0, min(isnoSV(ikl) - isl + 1, 1))
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ do isl = 1, min(nsno, isnoSV(ikl) + 1)
+
+ ! +--Combined Heat Conductivity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ mu_aux = CdidSV &
+ * (ro__SV(ikl, isl) / ro_Wat)**1.88
+ ! Combined Heat Conductivity For upper Layer
+ mu__dz(ikl, isl) = &
+ 2.*mu_aux * mu_sno(ikl) &
+ / max(epsi, dzsnSV(ikl, isl) * mu_sno(ikl) &
+ + dzsnSV(ikl, isl - 1) * mu_aux)
+ mu_sno(ikl) = mu_aux
+
+ ! +--Inverted Heat Capacity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^
+ ! dt / (dz X rho C)
+ dtC_sv(ikl, isl) = dt__SV / max(eps__3, &
+ dzsnSV(ikl, isl) * ro__SV(ikl, isl) * Cn_dSV)
+ enddo
+ enddo
+
+ ! +--Uppermost Effective Layer: NO conduction
+ ! + ----------------------------------------
+
+ do ikl = 1, klonv
+ mu__dz(ikl, isnoSV(ikl) + 1) = 0.0
+ enddo
+
+ ! +--Energy Budget (IN)
+ ! + ==================
+ do ikl = 1, klonv
+ ETSo_0(ikl) = 0.
+ enddo
+ do isl = -nsol, nsno
+ do ikl = 1, klonv
+ Exist0 = isl - isnoSV(ikl)
+ Exist0 = 1.-max(zero, min(unun, Exist0))
+ ETSo_0(ikl) = ETSo_0(ikl) &
+ + (TsisSV(ikl, isl) - TfSnow) * Exist0 &
+ / dtC_sv(ikl, isl)
+ enddo
+ enddo
+
+ ! +--Tridiagonal Elimination: Set Up
+ ! + ===============================
+
+ ! +--Soil/Snow Interior
+ ! + ^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ do isl = -nsol + 1, min(nsno - 1, isnoSV(ikl) + 1)
+ Elem_A = dtC_sv(ikl, isl) * mu__dz(ikl, isl)
+ Elem_C = dtC_sv(ikl, isl) * mu__dz(ikl, isl + 1)
+ Diag_A(ikl, isl) = -Elem_A * Implic
+ Diag_C(ikl, isl) = -Elem_C * Implic
+ Diag_B(ikl, isl) = 1.0d+0 - Diag_A(ikl, isl) - Diag_C(ikl, isl)
+ Term_D(ikl, isl) = Explic * (Elem_A * TsisSV(ikl, isl - 1) &
+ + Elem_C * TsisSV(ikl, isl + 1)) &
+ + (1.0d+0 - Explic * (Elem_A + Elem_C)) * TsisSV(ikl, isl) &
+ + dtC_sv(ikl, isl) * sol_SV(ikl) * SoSosv(ikl) &
+ * (sEX_sv(ikl, isl + 1) &
+ - sEX_sv(ikl, isl))
+ enddo
+ enddo
+
+ ! +--Soil lowest Layer
+ ! + ^^^^^^^^^^^^^^^^^^
+ isl = -nsol
+ do ikl = 1, klonv
+ Elem_A = 0.
+ Elem_C = dtC_sv(ikl, isl) * mu__dz(ikl, isl + 1)
+ Diag_A(ikl, isl) = 0.
+ Diag_C(ikl, isl) = -Elem_C * Implic
+ Diag_B(ikl, isl) = 1.0d+0 - Diag_A(ikl, isl) - Diag_C(ikl, isl)
+ Term_D(ikl, isl) = Explic * Elem_C * TsisSV(ikl, isl + 1) &
+ + (1.0d+0 - Explic * Elem_C) * TsisSV(ikl, isl) &
+ + dtC_sv(ikl, isl) * sol_SV(ikl) * SoSosv(ikl) &
+ * (sEX_sv(ikl, isl + 1) &
+ - sEX_sv(ikl, isl))
+ enddo
+
+ ! +--Snow highest Layer (dummy!)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isl = min(isnoSV(ikl) + 1, nsno)
+ Elem_A = dtC_sv(ikl, isl) * mu__dz(ikl, isl)
+ Elem_C = 0.
+ Diag_A(ikl, isl) = -Elem_A * Implic
+ Diag_C(ikl, isl) = 0.
+ Diag_B(ikl, isl) = 1.0d+0 - Diag_A(ikl, isl)
+ Term_D(ikl, isl) = Explic * Elem_A * TsisSV(ikl, isl - 1) &
+ + (1.0d+0 - Explic * Elem_A) * TsisSV(ikl, isl) &
+ + dtC_sv(ikl, isl) * (sol_SV(ikl) * SoSosv(ikl) &
+ * (sEX_sv(ikl, isl + 1) &
+ - sEX_sv(ikl, isl)))
+ enddo
+
+ ! +--Surface: UPwardIR Heat Flux
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isl = isnoSV(ikl)
+ ! - d(IR)/d(T)
+ dIRsdT(ikl) = Eso_sv(ikl) * stefan * 4. &
+ *TsisSV(ikl, isl) &
+ * TsisSV(ikl, isl) &
+ * TsisSV(ikl, isl)
+ IRs__D(ikl) = dIRsdT(ikl) * TsisSV(ikl, isl) * 0.75
+#if(RC)
+ ! +--Surface: Richardson Number: T Derivative
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ dRidTs(ikl) = -gravit * za__SV(ikl) &
+ * (1.-Sigmsv(ikl)) &
+ / (TaT_SV(ikl) * VV__SV(ikl) &
+ * VV__SV(ikl))
+#endif
+ ! +--Surface: Turbulent Heat Flux: Factors
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! common factor to HS, HL
+ f_HSHL(ikl) = rhT_SV(ikl) * (1.-Sigmsv(ikl)) / rah_sv(ikl)
+ f___HL(ikl) = f_HSHL(ikl) * Lx_H2O(ikl)
+
+ ! +--Surface: Sensible Heat Flux: T Derivative
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ dSdTSV(ikl) = f_HSHL(ikl) * Cp !#- d(HS)/d(T)
+ ! Richardson Nb. Correct.
+#if(RC)
+ dSdTSV(ikl) = dSdTSV(ikl) &
+ * (1.0 - (TsisSV(ikl, isl) - TaT_SV(ikl)) &
+ * dRidTs(ikl) * dFh_sv(ikl) / rah_sv(ikl))
+#endif
+ HS___D(ikl) = dSdTSV(ikl) * TaT_SV(ikl)
+
+ ! +--Surface: Latent Heat Flux: Saturation Specific Humidity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ sp = (pst_SV(ikl) + ptopSV) * 10.
+ psat_ice = 6.1070 * exp(6150.*(1./273.16 - 1./tsrf_SV(ikl)))
+ psat_wat = 6.1078 * exp(5.138 * log(273.16 / tsrf_SV(ikl))) &
+ * exp(6827.*(1./273.16 - 1./tsrf_SV(ikl)))
+
+ if(tsrf_SV(ikl) <= 273.15) then
+ qsatsg(ikl) = 0.622 * psat_ice / (sp - 0.378 * psat_ice)
+ else
+ qsatsg(ikl) = 0.622 * psat_wat / (sp - 0.378 * psat_wat)
+ endif
+ fac_dt(ikl) = f_HSHL(ikl) / (ro_Wat * dz_dSV(0))
+ enddo
+
+ ! +--Surface: Latent Heat Flux: Surface Relative Humidity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ xgpsrf = 1.05
+ agpsrf = dt__SV * (1.0 - xgpsrf) &
+ / (1.0 - xgpsrf**nt_srf)
+ dt_srf = agpsrf
+ dt_ver = 0.
+ do ikl = 1, klonv
+ isl = isnoSV(ikl)
+ ist = max(0, isotSV(ikl) - 100 * isnoSV(ikl)) ! 0 if H2O
+ ist__s = min(1, ist)
+ etaBAK(ikl) = max(epsi, eta_SV(ikl, isl))
+ etaNEW(ikl) = etaBAK(ikl)
+ etEuBk(ikl) = etaNEW(ikl)
+ enddo
+ if(ist__s == 1) then ! to reduce computer time
+ do it_srf = 1, nt_srf
+ dt_ver = dt_ver + dt_srf
+ do ikl = 1, klonv
+ faceta(ikl) = fac_dt(ikl) * dt_srf
+#if(VX)
+ ! Limitation by Atm.Conten NO Limitation of Downw.Flux
+ faceta(ikl) = faceta(ikl) &
+ / (1.+faceta(ikl) * dQa_SV(ikl))
+ ! *max(0,sign(1.,qsatsg(ikl)-QaT_SV(ikl))))
+#endif
+ enddo
+ do itEuBk = 1, 2
+ do ikl = 1, klonv
+ ! 0 if H2O
+ ist = max(0, isotSV(ikl) - 100 * isnoSV(ikl))
+ ! DR97, Eqn 3.34
+ Psi(ikl) = &
+ psidSV(ist) &
+ * (etadSV(ist) &
+ / max(etEuBk(ikl), epsi)) &
+ **bCHdSV(ist)
+ PsiArg(ikl) = 7.2E-5 * Psi(ikl)
+ RHuSol(ikl) = exp(-min(argmax, PsiArg(ikl)))
+ ! DR97, Eqn 3.15
+ SHuSol(ikl) = qsatsg(ikl) * RHuSol(ikl)
+ etEuBk(ikl) = &
+ (etaNEW(ikl) + faceta(ikl) * (QaT_SV(ikl) &
+ - SHuSol(ikl) &
+ * (1.-bCHdSV(ist) &
+ * PsiArg(ikl)))) &
+ / (1.+faceta(ikl) * SHuSol(ikl) &
+ * bCHdSV(ist) &
+ * PsiArg(ikl) &
+ / etaNEW(ikl))
+ etEuBk(ikl) = etEuBk(ikl) - Rootsv(ikl, 0) &
+ * dt_srf / (Ro_Wat * dz_dSV(0))
+ enddo
+ enddo
+ do ikl = 1, klonv
+ etaNEW(ikl) = max(etEuBk(ikl), epsi)
+ enddo
+ dt_srf = dt_srf * xgpsrf
+ enddo
+ endif
+
+ ! +--Surface: Latent Heat Flux: Soil/Water Surface Contributions
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isl = isnoSV(ikl)
+ ! 0 if H2O
+ ist = max(0, isotSV(ikl) - 100 * isnoSV(ikl))
+ ! 1 if no H2O
+ ist__s = min(1, ist)
+ ! 1 if H2O
+ ist__w = 1 - ist__s
+ ! latent heat flux computation
+ if(isotSV(ikl) > 1) then
+ ! to avoid too high flux
+ etaNEW(ikl) = max(etaNEW(ikl), 0.95 * etaBAK(ikl))
+ endif
+ HL___D(ikl) = (ist__s * ro_Wat * dz_dSV(0) * (etaNEW(ikl) - etaBAK(ikl)) / dt__SV &
+ + ist__w * f_HSHL(ikl) * (QaT_SV(ikl) - qsatsg(ikl))) * Lx_H2O(ikl)
+
+ dzVap0 = dt__SV * HL___D(ikl) * min(isl, 1) &
+ / (Lx_H2O(ikl) * max(ro__SV(ikl, isl), epsi))
+
+ if(isnoSV(ikl) > 0 .and. dzVap0 + dzsnSV(ikl, isl) <= 0) then
+ ist__s = 0
+ do while(dzVap0 + dzsnSV(ikl, isl) <= 0 .and. ist__s <= 10)
+ ist__s = ist__s + 1
+ HL___D(ikl) = HL___D(ikl) * 0.5
+ !HL___D(ikl) = HL___D(ikl) *0 ! for MAR-offline
+ dzVap0 = dt__SV * HL___D(ikl) * min(isl, 1) &
+ / (Lx_H2O(ikl) * max(ro__SV(ikl, isl), epsi))
+ print *, "sisvat_tso.f: HL___D too high on", ii__sv(ikl), jj__sv(ikl), nn__sv(ikl)
+ enddo
+ endif
+
+#if(DL)
+ RHuSol(ikl) = (QaT_SV(ikl) - HL___D(ikl) / f___HL(ikl)) / qsatsg(ikl)
+#endif
+
+ ! +--Surface: Latent Heat Flux: T Derivative
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ dLdTSV(ikl) = 0.
+ ! - d(HL)/d(T)
+#if(DL)
+ dLdTSV(ikl) = f___HL(ikl) * RHuSol(ikl) * dqs_dT(ikl)
+ HL___D(ikl) = HL___D(ikl) + dLdTSV(ikl) * TsisSV(ikl, isl)
+#endif
+ enddo
+
+ ! +--Surface: Tridiagonal Matrix Set Up
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isl = isnoSV(ikl)
+ TSurf0(ikl) = TsisSV(ikl, isl)
+ Elem_A = dtC_sv(ikl, isl) * mu__dz(ikl, isl)
+ Elem_C = 0.
+ Diag_A(ikl, isl) = -Elem_A * Implic
+ Diag_C(ikl, isl) = 0.
+ Diag_B(ikl, isl) = 1.0d+0 - Diag_A(ikl, isl)
+ Diag_B(ikl, isl) = Diag_B(ikl, isl) &
+ ! Upw. Sol IR
+ + dtC_sv(ikl, isl) * (dIRsdT(ikl) &
+ ! HS/Surf.Contr.
+ + dSdTSV(ikl) &
+ ! HL/Surf.Contr.
+ + dLdTSV(ikl))
+ Term_D(ikl, isl) = Explic * Elem_A * TsisSV(ikl, isl - 1) &
+ + (1.0d+0 - Explic * Elem_A) * TsisSV(ikl, isl)
+ Term_D(ikl, isl) = Term_D(ikl, isl) &
+ ! Absorbed
+ + dtC_sv(ikl, isl) * (sol_SV(ikl) * SoSosv(ikl) &
+ ! Solar
+ * (sEX_sv(ikl, isl + 1) &
+ - sEX_sv(ikl, isl)) &
+ ! Down Atm IR
+ + tau_sv(ikl) * IRd_SV(ikl) * Eso_sv(ikl) &
+ ! Down Veg IR
+ - (1.0 - tau_sv(ikl)) * 0.5 * IRv_sv(ikl) &
+ ! Upw. Sol IR
+ + IRs__D(ikl) &
+ ! HS/Atmo.Contr.
+ + HS___D(ikl) &
+ ! HL/Atmo.Contr.
+ + HL___D(ikl))
+ enddo
+
+ ! +--Tridiagonal Elimination
+ ! + =======================
+
+ ! +--Forward Sweep
+ ! + ^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ Aux__P(ikl, -nsol) = Diag_B(ikl, -nsol)
+ Aux__Q(ikl, -nsol) = -Diag_C(ikl, -nsol) / Aux__P(ikl, -nsol)
+ enddo
+
+ do ikl = 1, klonv
+ do isl = -nsol + 1, min(nsno, isnoSV(ikl) + 1)
+ Aux__P(ikl, isl) = Diag_A(ikl, isl) * Aux__Q(ikl, isl - 1) &
+ + Diag_B(ikl, isl)
+ Aux__Q(ikl, isl) = -Diag_C(ikl, isl) / Aux__P(ikl, isl)
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ TsisSV(ikl, -nsol) = Term_D(ikl, -nsol) / Aux__P(ikl, -nsol)
+ enddo
+
+ do ikl = 1, klonv
+ do isl = -nsol + 1, min(nsno, isnoSV(ikl) + 1)
+ TsisSV(ikl, isl) = (Term_D(ikl, isl) &
+ - Diag_A(ikl, isl) * TsisSV(ikl, isl - 1)) &
+ / Aux__P(ikl, isl)
+ enddo
+ enddo
+
+ ! +--Backward Sweep
+ ! + ^^^^^^^^^^^^^^
+ zt = 0.; ti = 0; izt = 1
+ do ikl = 1, klonv
+ do isl = isnoSV(ikl), 1, -1
+ zt(ikl) = zt(ikl) + dzsnSV(ikl, isl)
+ ti(ikl) = ti(ikl) + dzsnSV(ikl, isl) * TsisSV(ikl, isl)
+ if(zt(ikl) > 5) izt(ikl) = max(izt(ikl), isl)
+ enddo
+ ti(ikl) = min(271.15, ti(ikl) / max(0.01, zt(ikl)))
+ do isl = min(nsno - 1, isnoSV(ikl) + 1), -nsol, -1
+ TsisSV(ikl, isl) = Aux__Q(ikl, isl) * TsisSV(ikl, isl + 1) &
+ + TsisSV(ikl, isl)
+ if(isl == 0 .and. isnoSV(ikl) == 0) then
+
+ TsisSV(ikl, isl) = min(TaT_SV(ikl) + 30, TsisSV(ikl, isl))
+ TsisSV(ikl, isl) = max(TaT_SV(ikl) - 30, TsisSV(ikl, isl))
+#if(EU)
+ if(ivgtSV(ikl) /= 13) then ! city
+ TsisSV(ikl, isl) = min(TaT_SV(ikl) + 10., TsisSV(ikl, isl))
+ endif
+ TsisSV(ikl, isl) = max(TaT_SV(ikl) - 15., TsisSV(ikl, isl))
+ ! XF 18/11/2018 to avoid ST reaching 70C!!
+ ! It is an error compensation but does not work over tundra
+#endif
+ endif
+ if(zt(ikl) > 15 .and. isl <= 0) then ! ice sheet
+ TsisSV(ikl, isl) = max(223.15, min(ti(ikl), TsisSV(ikl, isl)))
+ eta_SV(ikl, isl) = epsi
+ endif
+ enddo
+ enddo
+
+ ! +--Temperature Limits (avoids problems in case of no Snow Layers)
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isl = isnoSV(ikl)
+ dTSurf = TsisSV(ikl, isl) - TSurf0(ikl)
+ ! 180.0 dgC/hr = 0.05 dgC/s
+ TsisSV(ikl, isl) = TSurf0(ikl) + sign(1., dTSurf) &
+ * min(abs(dTSurf), 5.e-2 * dt__SV)
+ enddo
+ do ikl = 1, klonv
+ do isl = min(nsno, isnoSV(ikl) + 1), 1, -1
+ TsisSV(ikl, isl) = max(Ts_Min, TsisSV(ikl, isl))
+ TsisSV(ikl, isl) = min(Ts_Max, TsisSV(ikl, isl))
+ enddo
+
+ if(zt(ikl) > 15 .and. isnoSV(ikl) > 4) then
+ ww = 3600.*24.*30./dt__SV ! 1 month
+ do isl = 1, min(izt(ikl), isnoSV(ikl) - 1)
+ if(TsisSV(ikl, isl + 1) < TsisSV(ikl, isl)) then
+ TsisSV(ikl, isl) = max(0.999 * TsisSV(ikl, isl), &
+ min(1.001 * TsisSV(ikl, isl), &
+ (TsisSV(ikl, isl) * dzsnSV(ikl, isl) * ww &
+ + TsisSV(ikl, isl + 1) * dzsnSV(ikl, isl + 1)) &
+ / (dzsnSV(ikl, isl) * ww &
+ + dzsnSV(ikl, isl + 1))))
+ TsisSV(ikl, isl + 1) = min(1.001 * TsisSV(ikl, isl + 1) &
+ , max(0.999 * TsisSV(ikl, isl + 1), &
+ (TsisSV(ikl, isl) * dzsnSV(ikl, isl) &
+ + TsisSV(ikl, isl + 1) * dzsnSV(ikl, isl + 1) * ww) &
+ / (dzsnSV(ikl, isl) &
+ + ww * dzsnSV(ikl, isl + 1))))
+
+ endif
+ enddo
+ if(ro__SV(ikl, 1) > 600 .and. TsisSV(ikl, 1) > 273.1) then
+ TsisSV(ikl, 1) = (TsisSV(ikl, 1) * dzsnSV(ikl, 1) &
+ + TsisSV(ikl, 2) * dzsnSV(ikl, 2)) / &
+ (dzsnSV(ikl, 1) + dzsnSV(ikl, 2))
+ endif
+ if(ro__SV(ikl, 2) > 600 .and. TsisSV(ikl, 2) > 273.1) then
+ TsisSV(ikl, 2) = (TsisSV(ikl, 1) * dzsnSV(ikl, 1) &
+ + TsisSV(ikl, 2) * dzsnSV(ikl, 2) &
+ + TsisSV(ikl, 3) * dzsnSV(ikl, 3)) / &
+ (dzsnSV(ikl, 1) + dzsnSV(ikl, 2) + dzsnSV(ikl, 3))
+ endif
+ endif
+ enddo
+
+ ! +--Update Surface Fluxes
+ ! + ========================
+ do ikl = 1, klonv
+ isl = isnoSV(ikl)
+ IRs_SV(ikl) = IRs__D(ikl) - dIRsdT(ikl) * TsisSV(ikl, isl)
+ ! Sensible Heat Downward > 0
+ HSs_sv(ikl) = HS___D(ikl) - dSdTSV(ikl) * TsisSV(ikl, isl)
+ ! Latent Heat Downward > 0
+ HLs_sv(ikl) = HL___D(ikl) - dLdTSV(ikl) * TsisSV(ikl, isl)
+#if(NC)
+ ! +--OUTPUT for Stand Alone NetCDF File
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! Absorbed Sol.
+ SOsoKL(ikl) = sol_SV(ikl) * SoSosv(ikl)
+ ! Up Surf. IR
+ ! Down Atm IR
+ ! Down Veg IR
+ IRsoKL(ikl) = IRs_SV(ikl) &
+ + tau_sv(ikl) * IRd_SV(ikl) * Eso_sv(ikl) &
+ - (1.0 - tau_sv(ikl)) * 0.5 * IRv_sv(ikl)
+ ! HS
+ HSsoKL(ikl) = HSs_sv(ikl)
+ ! HL
+ HLsoKL(ikl) = HLs_sv(ikl)
+ ! mm w.e./sec
+ HLs_KL(ikl) = HLs_sv(ikl) / Lv_H2O
+#endif
+ enddo
+
+ ! +--Energy Budget (OUT)
+ ! + ===================
+ do ikl = 1, klonv
+ ! Net Solar
+ ! Up Surf. IR
+ ! Down Atm IR
+ ! Down Veg IR
+ ! Sensible
+ ! Latent
+ ETSo_d(ikl) = (SoSosv(ikl) * sol_SV(ikl) &
+ + IRs_SV(ikl) &
+ + tau_sv(ikl) * IRd_SV(ikl) * Eso_sv(ikl) &
+ - (1.0 - tau_sv(ikl)) * 0.5 * IRv_sv(ikl) &
+ + HSs_sv(ikl) &
+ + HLs_sv(ikl))
+ ETSo_1(ikl) = 0.
+ enddo
+ do isl = -nsol, nsno
+ do ikl = 1, klonv
+ Exist0 = isl - isnoSV(ikl)
+ Exist0 = 1.-max(zero, min(unun, Exist0))
+ ETSo_1(ikl) = ETSo_1(ikl) + (TsisSV(ikl, isl) - TfSnow) * Exist0 / dtC_sv(ikl, isl)
+ enddo
+ enddo
+
+ return
+endsubroutine SISVAT_TSo
diff --git a/MAR/code_mar/sisvat_tvg.f90 b/MAR/code_mar/sisvat_tvg.f90
new file mode 100644
index 0000000000000000000000000000000000000000..433f68710863b3b6296857a9e85bfa928968b068
--- /dev/null
+++ b/MAR/code_mar/sisvat_tvg.f90
@@ -0,0 +1,378 @@
+#include "MAR_pp.def"
+subroutine SISVAT_TVg(ETVg_d)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_TVg 13-09-2003 MAR |
+ ! | subroutine SISVAT_TVg computes the Canopy Energy Balance |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: ivgtSV = 0,...,12: Vegetation Type |
+ ! | ^^^^^ 0: Water, Solid or Liquid |
+ ! | isnoSV = total Nb of Ice/Snow Layers |
+ ! | |
+ ! | INPUT: sol_SV : Downward Solar Radiation [W/m2] |
+ ! | ^^^^^ IRd_SV : Surface Downward Longwave Radiation [W/m2] |
+ ! | TaT_SV : SBL Top Temperature [K] |
+ ! | rhT_SV : SBL Top Air Density [kg/m3] |
+ ! | QaT_SV : SBL Top Specific Humidity [kg/kg] |
+ ! | psivSV : Leaf Water Potential [m] |
+ ! | IRs_SV : Soil IR Flux (previous time step) [W/m2] |
+ ! | dt__SV : Time Step [s] |
+ ! | |
+ ! | SoCasv : Absorbed Solar Radiation by Canopy (Normaliz)[-] |
+ ! | tau_sv : Fraction of Radiation transmitted by Canopy [-] |
+ ! | Evg_sv : Soil+Vegetation Emissivity [-] |
+ ! | Eso_sv : Soil+Snow Emissivity [-] |
+ ! | rah_sv : Aerodynamic Resistance for Heat [s/m] |
+ ! | Sigmsv : Canopy Ventilation Factor [-] |
+ ! | LAI_sv : Leaf Area Index [-] |
+ ! | LAIesv : Leaf Area Index (effective / transpiration) [-] |
+ ! | glf_sv : Green Leaf Fraction of NOT fallen Leaves [-] |
+ ! | rrMxsv : Canopy Maximum Intercepted Rain [kg/m2] |
+ ! | |
+ ! | INPUT / TvegSV : Canopy Temperature [K] |
+ ! | OUTPUT: rrCaSV : Canopy Water Content [kg/m2] |
+ ! | ^^^^^^ |
+ ! | |
+ ! | OUTPUT: IRv_sv : Vegetation IR Flux [W/m2] |
+ ! | ^^^^^^ HSv_sv : Sensible Heat Flux [W/m2] |
+ ! | HLv_sv : Latent Heat Flux [W/m2] |
+ ! | Evp_sv : Evaporation [kg/m2] |
+ ! | EvT_sv : Evapotranspiration [kg/m2] |
+ ! | ETVg_d : Vegetation Energy Power Forcing [W/m2] |
+ ! | |
+ ! | Internal Variables: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | |
+ ! | METHOD: The Newton-Raphson Scheme is preferable |
+ ! | ^^^^^^ when computing over a long time step the heat content |
+ ! | of a medium having a very small or zero heat capacity. |
+ ! | This is to handle strong non linearities arising |
+ ! | in conjunction with rapid temperature variations. |
+ ! | |
+ ! | # OPTIONS: #NN: Newton-Raphson Increment not added in last Iteration |
+ ! | # ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ ! +--OUTPUT
+ ! + ------
+
+ real ETVg_d(klonv) ! VegetationPower, Forcing
+#if(NC)
+ ! +--OUTPUT for Stand Alone NetCDF File
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! SOsoKL : Absorbed Solar Radiation
+ real SOsoKL(klonv)
+ ! IRsoKL : Absorbed IR Radiation
+ real IRsoKL(klonv)
+ ! HSsoKL : Absorbed Sensible Heat Flux
+ real HSsoKL(klonv)
+ ! HLsoKL : Absorbed Latent Heat Flux
+ real HLsoKL(klonv)
+ ! HLs_KL : Evaporation
+ real HLs_KL(klonv)
+ ! HLv_KL : Transpiration
+ real HLv_KL(klonv)
+ common / DumpNC / SOsoKL, IRsoKL, HSsoKL, HLsoKL, HLs_KL, HLv_KL
+#endif
+
+ ! +--Internal Variables
+ ! + ==================
+ ! ikl : Grid Point Index
+ integer ikl
+ ! nitmax, nit : Iterations Counter
+ integer nitmax, nit
+ ! d_Tveg : Canopy Temperat. Increment
+ real d_Tveg
+ ! dTvMAX : Canopy Temperat. Increment MAX
+ real dTvMAX
+ ! dHvdTv : Derivativ.of Canopy Energ.Budg.
+ real dHvdTv
+ ! Hv_Tv0 : Imbalance of Canopy Energ.Budg.
+ real Hv_Tv0
+ ! Hv_MAX : MAX Imbal.of Canopy Energ.Budg.
+ real Hv_MAX
+ ! Hv_MIN : MIN Imbal.of Canopy Energ.Budg.
+ real Hv_MIN
+ ! Hswich : Newton-Raphson Switch
+ real Hswich
+ ! Tveg_0 : Canopy Temperature, Previous t
+ real Tveg_0(klonv)
+ ! tau_Ca : Canopy IR Radiation Absorption
+ real tau_Ca
+ ! IR_net : InfraRed NET(t)
+ real IR_net
+ ! dIRdTv : InfraRed NET(t), Derivative(t)
+ real dIRdTv(klonv)
+ ! dHSdTv : Sensible Heat FL. Derivative(t)
+ real dHSdTv(klonv)
+ ! dHLdTv : Latent Heat FL. Derivative(t)
+ real dHLdTv(klonv)
+#if(HC)
+ ! dHCdTv : Heat Storage
+ real dHCdTv(klonv)
+#endif
+ ! EvFrac : Condensat./Transpirat. Switch
+ real EvFrac
+ ! SnoMsk : Canopy Snow Switch
+ real SnoMsk
+ ! den_qs, arg_qs, qsatvg : Canopy Saturat. Spec. Humidity
+ real den_qs, arg_qs, qsatvg
+ ! dqs_dT : d(qsatvg)/dTv
+ real dqs_dT
+ ! FacEvp, FacEvT, Fac_Ev : Evapo(transpi)ration Factor
+ real FacEvp, FacEvT, Fac_Ev
+ ! dEvpdT, dEvTdT : Evapo(transpi)ration Derivative
+ real dEvpdT(klonv), dEvTdT(klonv)
+ ! F_Stom : Funct. (Leaf Water Potential)
+ real F_Stom
+ ! R0Stom : Minimum Stomatal Resistance
+ real R0Stom
+ ! R_Stom : Stomatal Resistance
+ real R_Stom
+ ! LAI_OK : 1. ==> Leaves exist
+ real LAI_OK
+ ! rrCaOK, snCaOK, dEvpOK : Positive Definiteness Correct.
+ real rrCaOK, snCaOK, dEvpOK
+
+ ! +--Internal DATA
+ ! + =============
+ ! nitmax : Maximum Iterations Number
+ data nitmax/5/
+ ! dTvMAX : Canopy Temperat. Increment MAX
+ data dTvMAX/5./
+ ! Hv_MIN : MIN Imbal. of Surf.Energy Budg.
+ data Hv_MIN/0.1/
+ ! SnoMsk : Canopy Snow Switch (Default)
+ data SnoMsk/0.0/
+
+ ! +--Newton-Raphson Scheme
+ ! + =====================
+ nit = 0
+101 continue
+ nit = nit + 1
+ HV_MAX = 0.
+ ! +--Temperature of the Previous Time Step
+ ! + -------------------------------------
+ do ikl = 1, klonv
+ Tveg_0(ikl) = TvegSV(ikl)
+ ! +--IR Radiation Absorption
+ ! + -----------------------
+ ! Canopy Absorption
+ tau_Ca = 1.-tau_sv(ikl)
+ ! Downward IR (OUT) + Upward IR (OUT)
+ IRv_sv(ikl) = -2.0 * Evg_sv(ikl) * stefan &
+ * TvegSV(ikl) * TvegSV(ikl) &
+ * TvegSV(ikl) * TvegSV(ikl)
+ ! Downward IR (OUT) + Upward IR (OUT)
+ dIRdTv(ikl) = &
+ -Evg_sv(ikl) * &
+ 8.*stefan * TvegSV(ikl) * TvegSV(ikl) &
+ * TvegSV(ikl)
+ ! Downward IR (IN) - Upward IR (IN) + IR (OUT)
+ IR_net = tau_Ca * (Evg_sv(ikl) * IRd_SV(ikl) &
+ - IRs_SV(ikl) &
+ + IRv_sv(ikl))
+ ! +--Sensible Heat Flux
+ ! + ------------------
+ ! Derivative, t(n)
+ dHSdTv(ikl) = rhT_SV(ikl) * Sigmsv(ikl) * Cp &
+ / rah_sv(ikl)
+ ! Value, t(n)
+ HSv_sv(ikl) = dHSdTv(ikl) &
+ * (TaT_SV(ikl) - TvegSV(ikl))
+ ! +--Latent Heat Flux
+ ! + ------------------
+
+ ! +--Canopy Saturation Specific Humidity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ den_qs = TvegSV(ikl) - 35.8
+ arg_qs = 17.27 * (TvegSV(ikl) - 273.16) / den_qs
+ qsatvg = .0038 * exp(arg_qs)
+ dqs_dT = qsatvg * 4099.2 / (den_qs * den_qs)
+
+ ! +--Canopy Stomatal Resistance
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ ! Min Stomatal R.
+ R0Stom = min(StodSV(ivgtSV(ikl)) &
+ / max(epsi, glf_sv(ikl)), StxdSV)
+ ! F(Leaf Wat.Pot.) DR97, eqn. 3.22
+ F_Stom = pscdSV / max(pscdSV - psivSV(ikl), epsi)
+ ! Can.Stomatal R. DR97, eqn. 3.21
+ R_Stom = (R0Stom / max(LAIesv(ikl), R0Stom / StxdSV)) &
+ * F_Stom
+
+ ! +--Evaporation / Evapotranspiration
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ SnoMsk = max(zero, sign(unun, snCaSV(ikl) - eps_21))
+ ! Condensation/
+ EvFrac = max(zero, sign(unun, QaT_SV(ikl) - qsatvg))
+ ! Transpiration Switch
+ EvFrac = EvFrac &
+ + (1.-EvFrac) * ((1 - SnoMsk) * rrCaSV(ikl) &
+ / rrMxsv(ikl) &
+ + SnoMsk * min(unun, snCaSV(ikl) &
+ / rrMxsv(ikl)))
+ ! Idem, Factor
+ Fac_Ev = rhT_SV(ikl) * Sigmsv(ikl)
+ FacEvp = Fac_Ev * EvFrac / rah_sv(ikl)
+ ! Evaporation
+ Evp_sv(ikl) = FacEvp * (qsatvg - QaT_SV(ikl))
+ ! Evp Derivative
+ dEvpdT(ikl) = FacEvp * dqs_dT
+ FacEvt = Fac_Ev * (1.-EvFrac) / (rah_sv(ikl) &
+ + R_Stom * Sigmsv(ikl))
+ ! EvapoTranspir.
+ EvT_sv(ikl) = FacEvt * (qsatvg - QaT_SV(ikl))
+ ! EvT Derivative
+ dEvTdT(ikl) = FacEvt * dqs_dT
+ ! Latent Heat (Subli.Contrib.)
+ HLv_sv(ikl) = -Lv_H2O * (Evp_sv(ikl) + EvT_sv(ikl)) &
+ - Lf_H2O * Evp_sv(ikl) * SnoMsk
+ dHLdTv(ikl) = Lv_H2O * (dEvpdT(ikl) + dEvTdT(ikl)) &
+ + Lf_H2O * dEvpdT(ikl) * SnoMsk
+#if(HC)
+ ! Heat Storage
+ dHCdTv(ikl) = Cn_dSV * snCaSV(ikl) / dt__SV
+#endif
+
+ ! +--Imbalance of the Canopy Energy Budget
+ ! + ---------------------------------------
+ ! NO Budget if no Leaves
+ LAI_OK = max(zero, &
+ sign(unun, LAI_sv(ikl) - eps_21))
+ ! Absorbed Solar
+ ! NET IR
+ ! Sensible Heat
+ ! Latent Heat
+ Hv_Tv0 = (SoCasv(ikl) * sol_SV(ikl) &
+ + IR_net &
+ + HSv_sv(ikl) &
+ + HLv_sv(ikl) &
+ ) * LAI_OK
+ ! Veg.Energ.Bal.
+ ETVg_d(ikl) = Hv_Tv0
+ ! +
+ Hswich = unun
+#if(NN)
+ ! Newton-Raphson Switch
+ Hswich = max(zero, &
+ sign(unun, abs(Hv_Tv0) &
+ - Hv_MIN))
+#endif
+
+ ! +--Derivative of the Canopy Energy Budget
+ ! + ---------------------------------------
+
+ dHvdTv = dIRdTv(ikl) * max(eps_21, tau_Ca) &
+ - dHSdTv(ikl) &
+ - dHLdTv(ikl)
+#if(HC)
+ dHvdTv = dHvdTv - dHCdTv(ikl)
+#endif
+
+ ! +--Update Canopy and Surface/Canopy Temperatures
+ ! + ---------------------------------------------
+
+ d_Tveg = Hv_Tv0 / dHvdTv
+ ! Increment Limitor
+ d_Tveg = sign(unun, d_Tveg) &
+ * min(abs(d_Tveg), dTvMAX)
+ ! Newton-Raphson
+ TvegSV(ikl) = TvegSV(ikl) - Hswich * d_Tveg
+ Hv_MAX = max(Hv_MAX, abs(Hv_Tv0))
+
+ ! +--Update Vegetation Fluxes
+ ! + ------------------------
+#if(NN)
+ ! Emitted IR
+ IRv_sv(ikl) = IRv_sv(ikl) - dIRdTv(ikl) * d_Tveg
+ ! Sensible Heat
+ HSv_sv(ikl) = HSv_sv(ikl) + dHSdTv(ikl) * d_Tveg
+ ! Evapotranspir.
+ Evp_sv(ikl) = Evp_sv(ikl) - dEvpdT(ikl) * d_Tveg
+ ! Evapotranspir.
+ EvT_sv(ikl) = EvT_sv(ikl) - dEvTdT(ikl) * d_Tveg
+ ! Latent Heat
+ HLv_sv(ikl) = HLv_sv(ikl) + dHLdTv(ikl) * d_Tveg
+#endif
+ ! +
+ IRv_sv(ikl) = IRv_sv(ikl) * LAI_OK
+ HSv_sv(ikl) = HSv_sv(ikl) * LAI_OK
+ Evp_sv(ikl) = Evp_sv(ikl) * LAI_OK
+ EvT_sv(ikl) = EvT_sv(ikl) * LAI_OK
+ HLv_sv(ikl) = HLv_sv(ikl) * LAI_OK
+ enddo
+
+#if(IX)
+ if(nit < nitmax) go to 101
+#endif
+ if(Hv_MAX > Hv_MIN .and. nit < nitmax) go to 101
+
+ do ikl = 1, klonv
+ ! Emitted IR
+ IRv_sv(ikl) = IRv_sv(ikl) &
+ + dIRdTv(ikl) * (TvegSV(ikl) - Tveg_0(ikl))
+ ! Sensible Heat
+ HSv_sv(ikl) = HSv_sv(ikl) &
+ - dHSdTv(ikl) * (TvegSV(ikl) - Tveg_0(ikl))
+ ! Evaporation
+ Evp_sv(ikl) = Evp_sv(ikl) &
+ + dEvpdT(ikl) * (TvegSV(ikl) - Tveg_0(ikl))
+ ! Transpiration
+ EvT_sv(ikl) = EvT_sv(ikl) &
+ + dEvTdT(ikl) * (TvegSV(ikl) - Tveg_0(ikl))
+ ! Latent Heat
+ HLv_sv(ikl) = HLv_sv(ikl) &
+ - dHLdTv(ikl) * (TvegSV(ikl) - Tveg_0(ikl))
+
+ ! +--OUTPUT for Stand Alone NetCDF File
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#if(NC)
+ HLv_KL(ikl) = HLv_sv(ikl)
+#endif
+
+ ! +--Update Canopy Water Content
+ ! + ---------------------------
+
+ rrCaSV(ikl) = rrCaSV(ikl) - (1.-SnoMsk) * Evp_sv(ikl) * dt__SV
+ snCaSV(ikl) = snCaSV(ikl) - SnoMsk * Evp_sv(ikl) * dt__SV
+
+ ! +--Correction for Positive Definiteness (see WKarea/EvpVeg/EvpVeg.f)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ rrCaOK = max(rrCaSV(ikl), 0.)
+ snCaOK = max(snCaSV(ikl), 0.)
+ dEvpOK = (rrCaOK - rrCaSV(ikl) &
+ + snCaOK - snCaSV(ikl)) / dt__SV
+
+ ! Evaporation
+ Evp_sv(ikl) = Evp_sv(ikl) - dEvpOK
+ ! Latent Heat
+ HLv_sv(ikl) = HLv_sv(ikl) &
+ + (1.-SnoMsk) * Lv_H2O * dEvpOK &
+ + SnoMsk * (Lv_H2O + Lf_H2O) * dEvpOK
+
+ rrCaSV(ikl) = rrCaOK
+ snCaSV(ikl) = snCaOK
+
+ wee_SV(ikl, 2) = wee_SV(ikl, 2) + dt__SV * EvT_sv(ikl)
+ wee_SV(ikl, 1) = wee_SV(ikl, 1) + dt__SV * Evp_sv(ikl)
+
+ enddo
+
+ return
+endsubroutine SISVAT_TVg
diff --git a/MAR/code_mar/sisvat_vgt_albedo.f90 b/MAR/code_mar/sisvat_vgt_albedo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5810b0cfa8e12e048eb9118a87eff50b65cf7d44
--- /dev/null
+++ b/MAR/code_mar/sisvat_vgt_albedo.f90
@@ -0,0 +1,424 @@
+#include "MAR_pp.def"
+subroutine VgOptP
+ ! +------------------------------------------------------------------------+
+ ! | MAR/SISVAT VgOptP 8-03-2022 MAR |
+ ! | subroutine VgOptP computes the Canopy optical Properties |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental Grid Boxes |
+ ! | X Number of Mosaic Cell per Grid Box |
+ ! | |
+ ! | INPUT: ivgtSV = 0,...,12: Vegetation Type |
+ ! | ^^^^^ 0: Water, Solid or Liquid |
+ ! | |
+ ! | INPUT: coszSV : Cosine of the Sun Zenithal Distance [-] |
+ ! | ^^^^^ sol_SV : Surface Downward Solar Radiation [W/m2] |
+ ! | snCaSV : Canopy Snow Thickness [mm w.e.] |
+ ! | |
+ ! | LAI_sv : Leaf Area Index (snow included) [-] |
+ ! | glf_sv : Green Leaf Fraction of NOT fallen Leaves [-] |
+ ! | albisv : Snow/Ice/Water/Soil Integrated Albedo [-] |
+ ! | |
+ ! | OUTPUT: alb_SV : Surface-Canopy Albedo [-] |
+ ! | ^^^^^^ SoCasv : Absorbed Solar Radiation by Canopy (Normaliz)[-] |
+ ! | SoSosv : Absorbed Solar Radiation by Surfac (Normaliz)[-] |
+ ! | LAIesv : Effective Leaf Area Index for Transpiration [-] |
+ ! | |
+ ! | Internal Variables: Normalized Values: |
+ ! | ^^^^^^^^^^^^^^^^^^ |
+ ! | u0_Vis : Upward Visible Radiation at Top Canopy [-] |
+ ! | absg_V : Absorbed Visible Radiation by the Ground [-] |
+ ! | absv_V : Absorbed Visible Radiation by the Canopy [-] |
+ ! | u0_nIR : Upward Near IR Radiation at Top Canopy [-] |
+ ! | absgnI : Absorbed Near IR Radiation by the Ground [-] |
+ ! | absv_V : Absorbed Near IR Radiation by the Canopy [-] |
+ ! | |
+ ! | REFERENCE: De Ridder, 1997, unpublished thesis, chapter 2 (DR97,2) |
+ ! | ^^^^^^^^^ |
+ ! | |
+ ! | ASSUMPTIONS: Leaf Inclination Index chi_l (eqn2.49 DR97) set to zero |
+ ! | ^^^^^^^^^^^ for all vegetation types |
+ ! | Radiation Fluxes are normalized |
+ ! | with respect to incoming solar radiation (=I0+D0) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--Internal Variables
+ ! + ==================
+
+ integer ikl, kri
+
+ real exdRad, k_drad, k___sv(klonv)
+ real e_prad, e1pRad
+ real zv_fac, zv1fac, deadLF
+ real T_Rad0, A_Rad0, A0__sv(klonv)
+ real r0_Rad, t0_Rad, nu_Rad
+ real Tr_Rad, Re_Rad, r__Rad, t__Rad, t1_Rad
+ real arggam, gamma, gamasv(klonv), gammaL
+ real denSig, Sig__c, Sigcsv(klonv)
+ real DDifH1, DDifC1, C1__sv(klonv)
+ real DDifH2, DDifC2, C2__sv(klonv)
+ real denS_s, denS_a, den_c1, DDif_L
+ real u0_Vis, absg_V, absv_V
+ real u0_nIR, absgnI, absvnI
+ real argexg, argexk, criLAI(klonv)
+ real residu, d_DDif, dDDifs, dDDifa
+
+ ! +--Internal DATA
+ ! + =============
+
+ integer nvgt
+ parameter(nvgt=13)
+ real reVisL(0:nvgt) ! Reflectivity / Visible / Live Leaves
+ real renIRL(0:nvgt) ! Reflectivity / Near IR / Live Leaves
+ real trVisL(0:nvgt) ! Transmitivity / Visible / Live Leaves
+ real trnIRL(0:nvgt) ! Transmitivity / Near IR / Live Leaves
+ real reVisD(0:nvgt) ! Reflectivity / Visible / Dead Leaves
+ real renIRD(0:nvgt) ! Reflectivity / Near IR / Dead Leaves
+ real trVisD(0:nvgt) ! Transmitivity / Visible / Dead Leaves
+ real trnIRD(0:nvgt) ! Transmitivity / Near IR / Dead Leaves
+
+ real reVisS ! Reflectivity / Visible / Canopy Snow
+ real renIRS ! Reflectivity / Near IR / Canopy Snow
+ real trVisS ! Transmitivity / Visible / Canopy Snow
+ real trnIRS ! Transmitivity / Near IR / Canopy Snow
+
+ real snCaMx ! Canopy Snow Thickness for having Snow
+ ! ! Snow Reflectivity and Transmitivity
+ real CriStR ! Critical Radiation Stomatal Resistance
+ real alb_SV_old
+
+ integer ivg
+
+ DATA(reVisL(ivg), renIRL(ivg), trVisL(ivg), trnIRL(ivg), &
+ reVisD(ivg), renIRD(ivg), trVisD(ivg), trnIRD(ivg), ivg=0, nvgt) &
+ ! 0 NO VEGETATION
+ / 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 1 CROPS LOW
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 2 CROPS MEDIUM
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 3 CROPS HIGH
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 4 GRASS LOW
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 5 GRASS MEDIUM
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 6 GRASS HIGH
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38, &
+ ! 7 BROADL LOW
+ 0.10, 0.45, 0.05, 0.25, 0.16, 0.39, 0.01, 0.01, &
+ ! 8 BROADL MEDIUM
+ 0.10, 0.45, 0.05, 0.25, 0.16, 0.39, 0.01, 0.01, &
+ ! 9 BROADL HIGH
+ 0.10, 0.45, 0.05, 0.25, 0.16, 0.39, 0.01, 0.01, &
+ ! 10 NEEDLE LOW
+ 0.07, 0.35, 0.05, 0.10, 0.10, 0.39, 0.01, 0.01, &
+ ! 11 NEEDLE MEDIUM
+ 0.07, 0.35, 0.05, 0.10, 0.10, 0.39, 0.01, 0.01, &
+ ! 12 NEEDLE HIGH
+ 0.07, 0.35, 0.05, 0.10, 0.10, 0.39, 0.01, 0.01, &
+ ! 13 City
+ 0.11, 0.58, 0.07, 0.25, 0.36, 0.58, 0.22, 0.38 /
+
+ DATA &
+ reVisS, renIRS, trVisS, trnIRS &
+ /0.85, 0.85, 0.00, 0.00/!
+ ! + REMARK: Possible Refinement by taking actual Surface Snow Reflectivities
+ ! + ^^^^^^
+
+ DATA snCaMx/0.5/
+
+ DATA CriStR/25./
+
+ ! +--General Parameters, Solar Radiation Absorption
+ ! + ==============================================
+
+ do ikl = 1, klonv
+
+#if(sv)
+ if(ifraSV(ikl) > 0) then
+#endif
+
+ ! absorbed irradiance fraction
+ k_dRad = 0.5 / max(coszSV(ikl), epsi)
+ ! exponential argument,
+ ! V/nIR radiation partitioning,
+ ! DR97, 2, eqn (2.53) & (2.54)
+ e_pRad = 2.5 * coszSV(ikl)
+ ! exponential, Irradi. Absorpt.
+ exdRad = exp(-k_dRad * LAI_sv(ikl))
+ ! exponential, V/nIR Rad. Part.
+ e1pRad = 1.-exp(-e_pRad)
+
+ ! Vegetation Type
+ ivg = ivgtSV(ikl)
+ ! Contribution of Snow to Leaf Reflectivity and Transmissiv.
+ zv_fac = min(snCaSV(ikl) / snCaMx &
+ , unun)
+ zv1fac = 1.-zv_fac
+ ! Dead Leaf Fraction
+ deadLF = 1.-glf_sv(ikl)
+
+ ! +--Visible Part of the Solar Radiation Spectrum (V, 0.4--0.7mi.m)
+ ! + ================================================================
+
+ A_Rad0 = 0.25 + 0.697 * e1pRad ! Absorbed Vis. Radiation
+ T_Rad0 = 1.-A_Rad0 ! Transmitted Vis Radiation
+
+ ! +--Reflectivity, Transmissivity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Re_Rad = glf_sv(ikl) * ReVisL(ivg) &
+ + deadLF * ReVisD(ivg)
+ Tr_Rad = glf_sv(ikl) * TrVisL(ivg) &
+ + deadLF * TrVisD(ivg)
+
+ ! +--Adaptation to Snow
+ ! + ^^^^^^^^^^^^^^^^^^
+ Re_Rad = zv1fac * Re_Rad + zv_fac * reVisS
+ Tr_Rad = zv1fac * Tr_Rad + zv_fac * trVisS
+
+ ! +--Scattering /DR97, 2, eqn (2.26) and (2.27) ! Diffuse Radiation:
+ ! + ^^^^^^^^^^ ! ^^^^^^^^^^^^^^^^^^
+ r__Rad = (2.*Re_Rad + Tr_Rad) / 3. ! Upw. Scatter.Fract.
+ t__Rad = (Re_Rad + 2.*Tr_Rad) / 3. ! Downw.Scatter.Fract.
+
+ t1_Rad = 1.-t__Rad !
+ arggam = t1_Rad * t1_Rad - r__Rad * r__Rad !
+ arggam = max(arggam, zero) !
+ gamma = sqrt(arggam) ! eqn (2.39)
+ gammaL = min(gamma * LAI_sv(ikl), 40.0) !
+ DDifH1 = exp(gammaL) ! Downw.Diffus.Solut.1
+ DDifH2 = exp(-gammaL) ! Downw.Diffus.Solut.2
+ ! + REMARK: These 2 contributions are zero in case of 0 Reflectivity
+ ! + ^^^^^^
+
+ ! +--Scattering /DR97, 2, eqn (2.19) and (2.20) ! Direct Radiation:
+ ! + ^^^^^^^^^^ ! ^^^^^^^^^^^^^^^^^^
+ ! Upw. Scatter.Fract.
+ r0_Rad = 0.5 * ((Re_Rad + Tr_Rad) * k_dRad &
+ + (Re_Rad - Tr_Rad) / 3.) !
+ t0_Rad = 0.5 * ((Re_Rad + Tr_Rad) * k_dRad &
+ ! Downw.Scatter.Fract.
+ - (Re_Rad - Tr_Rad) / 3.)
+ ! nu coeff., eqn 2.43
+ nu_Rad = t1_Rad - r__Rad * albisv(ikl)
+ ! eqn (2.43) Denomin.
+ !(Constant for DDifH1)
+ den_c1 = gamma * (DDifH1 + DDifH2) &
+ + nu_Rad * (DDifH1 - DDifH2)
+
+ ! eqn (2.40) Denomin.
+ denSig = gamma * gamma - k_dRad * k_dRad
+ denS_s = sign(unun, denSig)
+ denS_a = abs(denSig)
+ denSig = max(epsi, denS_a) * denS_s
+ ! sigma_c, eqn (2.40)
+ Sig__c = (r__Rad * r0_Rad &
+ + t0_Rad * (k_dRad + t1_Rad)) / denSig
+
+ DDifC1 = ((gamma - nu_Rad) * (T_Rad0 - Sig__c * A_Rad0) * DDifH2 &
+ + ((k_dRad - nu_Rad) * Sig__c &
+ + t0_Rad + r__Rad * albisv(ikl)) * A_Rad0 * exdRad) &
+ / max(den_c1, epsi)
+ DDifC2 = T_Rad0 - DDifC1 - Sig__c * A_Rad0
+
+ ! +--Visible Diffuse Fluxes
+ ! + ^^^^^^^^^^^^^^^^^^^^^^
+ ! DOWNward, Canopy Basis
+ DDif_L = DDifC1 * DDifH1 + DDifC2 * DDifH2 &
+ + Sig__c * A_Rad0 * exdRad
+ ! UPward Canopy Top
+ u0_Vis = ((gamma + t1_Rad) * DDifC1 &
+ - (gamma - t1_Rad) * DDifC2 &
+ - ((k_dRad - t1_Rad) * Sig__c &
+ + t0_Rad) * A_Rad0) &
+ / max(r__Rad, epsi)
+ ! ERROR
+ u0_Vis = min(0.99, max(epsi, u0_Vis))
+ ! Ground Absorption
+ absg_V = (1.-albisv(ikl)) * (A_Rad0 * exdRad &
+ + DDif_L) !
+ ! Veget. Absorption
+ absv_V = (1.-u0_Vis) - absg_V
+
+ ! +--Parameters for Computing Effective LAI for Transpiration
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ gamasv(ikl) = gamma
+ C1__sv(ikl) = DDifC1
+ C2__sv(ikl) = DDifC2
+ Sigcsv(ikl) = Sig__c
+ k___sv(ikl) = k_dRad
+ A0__sv(ikl) = A_Rad0
+
+ ! +--Near-IR Part of the Solar Radiation Spectrum (nIR, 0.7--2.8mi.m)
+ ! + ================================================================
+
+ A_Rad0 = 0.80 + 0.185 * e1pRad ! Absorbed nIR. Radiation
+ T_Rad0 = 1.-A_Rad0 ! Transmitted nIR Radiation
+
+ ! +--Reflectivity, Transmissivity
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ Re_Rad = glf_sv(ikl) * RenIRL(ivg) &
+ + deadLF * RenIRD(ivg)
+ Tr_Rad = glf_sv(ikl) * TrnIRL(ivg) &
+ + deadLF * TrnIRD(ivg)
+
+ ! +--Adaptation to Snow
+ ! + ^^^^^^^^^^^^^^^^^^
+ Re_Rad = zv1fac * Re_Rad + zv_fac * renIRS
+ Tr_Rad = zv1fac * Tr_Rad + zv_fac * trnIRS
+
+ ! +--Scattering /DR97, 2, eqn (2.26) and (2.27) ! Diffuse Radiation:
+ ! + ^^^^^^^^^^ ! ^^^^^^^^^^^^^^^^^^
+ ! Upw. Scatter.Fract.
+ r__Rad = (2.*Re_Rad + Tr_Rad) / 3.
+ ! Downw.Scatter.Fract.
+ t__Rad = (Re_Rad + 2.*Tr_Rad) / 3.
+
+ t1_Rad = 1.-t__Rad
+ arggam = t1_Rad * t1_Rad - r__Rad * r__Rad
+ arggam = max(arggam, zero)
+ ! eqn (2.39)
+ gamma = sqrt(arggam)
+ ! Downw.Diffus.Solut.1
+ DDifH1 = exp(gamma * LAI_sv(ikl))
+ ! Downw.Diffus.Solut.2
+ DDifH2 = exp(-gamma * LAI_sv(ikl))
+ ! + REMARK: These 2 contributions are zero in case of 0 Reflectivity
+ ! + ^^^^^^
+
+ ! +--Scattering /DR97, 2, eqn (2.19) and (2.20) ! Direct Radiation:
+ ! + ^^^^^^^^^^ ! ^^^^^^^^^^^^^^^^^^
+ ! Upw. Scatter.Fract.
+ r0_Rad = 0.5 * ((Re_Rad + Tr_Rad) * k_dRad &
+ + (Re_Rad - Tr_Rad) / 3.) !
+ ! Downw.Scatter.Fract.
+ t0_Rad = 0.5 * ((Re_Rad + Tr_Rad) * k_dRad &
+ - (Re_Rad - Tr_Rad) / 3.) !
+
+ ! nu coeff., eqn 2.43
+ nu_Rad = t1_Rad - r__Rad * albisv(ikl)
+ ! eqn (2.43) Denomin. (Constant for DDifH1)
+ den_c1 = gamma * (DDifH1 + DDifH2) &
+ + nu_Rad * (DDifH1 - DDifH2)
+
+ ! eqn (2.40) Denomin.
+ denSig = gamma * gamma - k_dRad * k_dRad
+ denS_s = sign(unun, denSig)
+ denS_a = abs(denSig)
+ denSig = max(epsi, denS_a) * denS_s
+ ! sigma_c, eqn (2.40)
+ Sig__c = (r__Rad * r0_Rad &
+ + t0_Rad * (k_dRad + t1_Rad)) / denSig
+
+ DDifC1 = ((gamma - nu_Rad) * (T_Rad0 - Sig__c * A_Rad0) * DDifH2 &
+ + ((k_dRad - nu_Rad) * Sig__c &
+ + t0_Rad + r__Rad * albisv(ikl)) * A_Rad0 * exdRad) &
+ / max(den_c1, epsi)
+ DDifC2 = T_Rad0 - DDifC1 - Sig__c * A_Rad0
+
+ ! +--Near IR Diffuse Fluxes
+ ! + ^^^^^^^^^^^^^^^^^^^^^^
+ ! DOWNward, Canopy Basis
+ DDif_L = DDifC1 * DDifH1 + DDifC2 * DDifH2 &
+ + Sig__c * A_Rad0 * exdRad
+ ! UPward Canopy Top
+ u0_nIR = ((gamma + t1_Rad) * DDifC1 &
+ - (gamma - t1_Rad) * DDifC2 &
+ - ((k_dRad - t1_Rad) * Sig__c &
+ + t0_Rad) * A_Rad0) &
+ / max(r__Rad, epsi)
+ ! ERROR
+ u0_nIR = min(0.99, max(epsi, u0_nIR))
+ ! Ground Absorption
+ absgnI = (1.-albisv(ikl)) * (A_Rad0 * exdRad &
+ + DDif_L)
+ ! Veget. Absorption
+ absvnI = (1.-u0_nIR) - absgnI
+
+ ! +--Surface-Canopy Albedo and Normalized Solar Radiation Absorption
+ ! + ===============================================================
+
+ alb_SV_old = (u0_Vis + u0_nIR) * 0.5d0
+ alb_SV(ikl) = (u0_Vis + u0_nIR) * 0.5d0
+
+ !XF if vegetation albedo too low
+ ! if(alb_SV_old<0.3.and.alb_SV_old>0.01&
+ ! .and.ivgtSV(ikl)>0)then
+ ! alb_SV(ikl) = alb_SV_old + (0.3 - alb_SV_old) / 5.
+ ! u0_nIR = u0_nIR * alb_SV(ikl) / alb_SV_old
+ ! u0_Vis = u0_Vis * alb_SV(ikl) / alb_SV_old
+ ! absvnI = (1. - u0_nIR) - absgnI
+ ! absv_V = (1. - u0_Vis) - absg_V
+ ! else
+ ! alb_SV(ikl) = (u0_Vis + u0_nIR) * 0.5d0
+ ! end if
+
+ if(ivgtSV(ikl) == 13) then ! city
+ alb_SV(ikl) = min(0.1, alb_SV(ikl))
+ endif
+ !XF
+ SoCasv(ikl) = (absv_V + absvnI) * 0.5d0
+ SoSosv(ikl) = (absg_V + absgnI) * 0.5d0
+
+#if(sv)
+ endif
+#endif
+
+ enddo
+
+ ! +--Effective LAI for Transpiration
+ ! + ===============================
+
+ do ikl = 1, klonv
+ criLAI(ikl) = 2. ! LAI for which D0_Vis > 20W/m2
+ ! + ! DR97, 2, eqn (2.57)
+ enddo
+
+ do kri = 1, 10
+ do ikl = 1, klonv
+
+#if(sv)
+ if(ifraSV(ikl) > 0) then
+#endif
+ argexg = min(criLAI(ikl) * gamasv(ikl), argmax)
+ argexk = min(criLAI(ikl) * k___sv(ikl), argmax)
+ residu = C1__sv(ikl) * exp(argexg) &
+ + C2__sv(ikl) * exp(-argexg) &
+ + A0__sv(ikl) * gamasv(ikl) * exp(-argexk) &
+ - CriStR / max(sol_SV(ikl), epsi)
+
+ d_DDif = C1__sv(ikl) * gamasv(ikl) * exp(argexg) &
+ - C2__sv(ikl) * gamasv(ikl) * exp(-argexg) &
+ - A0__sv(ikl) * k___sv(ikl) * exp(-argexk)
+ dDDifs = sign(unun, d_DDif)
+ dDDifa = abs(d_DDif)
+ d_DDif = max(epsi, dDDifa) * dDDifs
+
+ criLAI(ikl) = criLAI(ikl) - residu / d_DDif
+ criLAI(ikl) = max(criLAI(ikl), zero)
+ criLAI(ikl) = min(criLAI(ikl), LAI_sv(ikl))
+#if(sv)
+ endif
+#endif
+
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ LAIesv(ikl) = criLAI(ikl) + (exp(-k___sv(ikl) * criLAI(ikl)) &
+ - exp(-k___sv(ikl) * LAI_sv(ikl))) &
+ / k___sv(ikl)
+ enddo
+
+ return
+endsubroutine VgOptP
diff --git a/MAR/code_mar/sisvat_weq.f90 b/MAR/code_mar/sisvat_weq.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6a9a2e6debcaa0cb6faa348f1a2eb0010166e361
--- /dev/null
+++ b/MAR/code_mar/sisvat_weq.f90
@@ -0,0 +1,89 @@
+#include "MAR_pp.def"
+subroutine SISVAT_wEq(labWEq, istart)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_wEq 22-09-2001 MAR |
+ ! | subroutine SISVAT_wEq computes the Snow/Ice Water Equivalent |
+ ! | |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SISVAT_wEq.ve | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. |
+ ! | | unit 45, subroutine SISVAT_wEq **ONLY** |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use marxsv
+
+ implicit none
+
+ character * 6 labWEq
+ integer istart
+
+ logical logWEq
+ common / SISVAT_wEq_L / logWEq
+
+ ! +--Local Variables
+ ! + ================
+
+ integer ikl, isn
+ real SnoWEQ, IceWEQ
+
+ ! +--Switch Initialization
+ ! + =====================
+
+ if(.not. logWEq) then
+ logWEq = .true.
+ open(unit=45, status='unknown', file='SISVAT_wEq.ve')
+ rewind 45
+ endif
+
+ ! +--Snow Water Equivalent
+ ! + =====================
+
+ ikl = 1
+ if(isnoSV(ikl) > iiceSV(ikl)) then
+
+ SnoWEQ = 0.
+ do isn = iiceSV(ikl) + 1, isnoSV(ikl)
+ SnoWEQ = SnoWEQ + ro__SV(ikl, isn) * dzsnSV(ikl, isn)
+ enddo
+
+ endif
+
+ ! +--Ice Water Equivalent
+ ! + =====================
+
+ if(iiceSV(1) > 0) then
+
+ IceWEQ = 0.
+ do isn = 1, iiceSV(ikl)
+ IceWEQ = IceWEQ + ro__SV(ikl, isn) * dzsnSV(ikl, isn)
+ enddo
+
+ endif
+
+ ! +--OUTPUT
+ ! + ======
+
+ if(istart == 1) then
+ write(45, 45) dahost, i___SV(lwriSV(1)), j___SV(lwriSV(1)), &
+ n___SV(lwriSV(1))
+45 format(a18, 10('-'), 'Pt.', 3i4, 60('-'))
+ endif
+
+ write(45, 450) labWEq, IceWEQ, iiceSV(ikl), SnoWEQ &
+ , IceWEQ + SnoWEQ, isnoSV(ikl) &
+ , drr_SV(ikl) * dt__SV &
+ , dsn_SV(ikl) * dt__SV &
+ , BufsSV(ikl)
+450 format(a6, 3x, ' I+S =', f11.4, '(', i2, ') +', f11.4, ' =', &
+ f11.4, '(', i2, ')', &
+ ' drr =', f7.4, &
+ ' dsn =', f7.4, &
+ ' Buf =', f7.4)
+
+ return
+endsubroutine SISVAT_wEq
diff --git a/MAR/code_mar/sisvat_zag.f90 b/MAR/code_mar/sisvat_zag.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b09fdca068ac73c9c36eb24851b2cd85cc0a9cdf
--- /dev/null
+++ b/MAR/code_mar/sisvat_zag.f90
@@ -0,0 +1,254 @@
+#include "MAR_pp.def"
+subroutine SISVAT_zAg(isagra, isagrb, WEagra &
+ , dzagra, dzagrb, T_agra, T_agrb &
+ , roagra, roagrb, etagra, etagrb &
+ , G1agra, G1agrb, G2agra, G2agrb &
+ , agagra, agagrb, Agreg1)
+ ! +------------------------------------------------------------------------+
+ ! | MAR SURFACE Sat 30-Apr-2004 MAR |
+ ! | subroutine SISVAT_zAg aggregates two contiguous snow layers |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT: isagrb : 2nd Layer History |
+ ! | ^^^^^ |
+ ! | |
+ ! | INPUT: dzagrb : 2nd Layer Thickness |
+ ! | ^^^^^ T_agrb : 2nd Layer Temperature |
+ ! | roagrb : 2nd Layer Density |
+ ! | etagrb : 2nd Layer Water Content |
+ ! | G1agrb : 2nd Layer Dendricity/Spher. |
+ ! | G2agrb : 2nd Layer Sphericity/Size |
+ ! | agagrb : 2nd Age |
+ ! | Agreg1 : 1. when Agregation constrained |
+ ! | |
+ ! | INPUT / isagra : 1st Layer History |
+ ! | OUTPUT: |
+ ! | ^^^^^^ |
+ ! | |
+ ! | INPUT / dzagra : 1st Layer Thickness |
+ ! | OUTPUT: T_agra : 1st Layer Temperature |
+ ! | ^^^^^^ roagra : 1st Layer Density |
+ ! | etagra : 1st Layer Water Content |
+ ! | G1agra : 1st Layer Dendricity/Spher. |
+ ! | G2agra : 1st Layer Sphericity/Size |
+ ! | agagra : 1st Age |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardSV
+ use mar0SV
+ use marxsv
+
+ implicit none
+
+ ! +--INPUT
+ ! + -----
+
+ integer isagrb(klonv) ! 2nd Layer History
+ real dzagrb(klonv) ! 2nd Layer Thickness
+ real T_agrb(klonv) ! 2nd Layer Temperature
+ real roagrb(klonv) ! 2nd Layer Density
+ real etagrb(klonv) ! 2nd Layer Water Content
+ real G1agrb(klonv) ! 2nd Layer Dendricity/Spher.
+ real G2agrb(klonv) ! 2nd Layer Sphericity/Size
+ real agagrb(klonv) ! 2nd Layer Age
+
+ ! +--INPUT/OUTPUT
+ ! + ------------
+
+ integer isagra(klonv) ! 1st Layer History
+ real WEagra(klonv) ! 1st Layer Height [mm w.e.]
+ real Agreg1(klonv) ! 1. ===> Agregates
+ real dzagra(klonv) ! 1st Layer Thickness
+ real T_agra(klonv) ! 1st Layer Temperature
+ real roagra(klonv) ! 1st Layer Density
+ real etagra(klonv) ! 1st Layer Water Content
+ real G1agra(klonv) ! 1st Layer Dendricity/Spher.
+ real G2agra(klonv) ! 1st Layer Sphericity/Size
+ real agagra(klonv) ! 1st Layer Age
+
+ ! +--Internal Variables
+ ! + ==================
+
+ integer ikl
+ integer nh ! Averaged Snow History
+ integer nh__OK ! 1=>Conserve Snow History
+ real rh !
+ real dz ! Thickness
+ real dzro_1 ! Thickness X Density, Lay.1
+ real dzro_2 ! Thickness X Density, Lay.2
+ real dzro ! Thickness X Density, Aver.
+ real ro ! Averaged Density
+ real wn ! Averaged Water Content
+ real tn ! Averaged Temperature
+ real ag ! Averaged Snow Age
+ real SameOK ! 1. => Same Type of Grains
+ real G1same ! Averaged G1, same Grains
+ real G2same ! Averaged G2, same Grains
+ real typ__1 ! 1. => Lay1 Type: Dendritic
+ real zroNEW ! dz X ro, if fresh Snow
+ real G1_NEW ! G1, if fresh Snow
+ real G2_NEW ! G2, if fresh Snow
+ real zroOLD ! dz X ro, if old Snow
+ real G1_OLD ! G1, if old Snow
+ real G2_OLD ! G2, if old Snow
+ real SizNEW ! Size, if fresh Snow
+ real SphNEW ! Spheric.,if fresh Snow
+ real SizOLD ! Size, if old Snow
+ real SphOLD ! Spheric.,if old Snow
+ real Siz_av ! Averaged Grain Size
+ real Sph_av ! Averaged Grain Spher.
+ real Den_av ! Averaged Grain Dendr.
+ real DendOK ! 1. => Average is Dendr.
+ real G1diff ! Averaged G1, diff. Grains
+ real G2diff ! Averaged G2, diff. Grains
+ real G1 ! Averaged G1
+ real G2 ! Averaged G2
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+ common / SISVAT_EV / iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+#endif
+
+ ! +--Mean Properties
+ ! + =================
+
+ ! +-- 1 Densite, Contenu en Eau, Temperature /
+ ! + Density, Water Content, Temperature
+ ! + ------------------------------------
+
+ do ikl = 1, klonv
+ dz = dzagra(ikl) + dzagrb(ikl)
+ dzro_1 = roagra(ikl) * dzagra(ikl)
+ dzro_2 = roagrb(ikl) * dzagrb(ikl)
+ dzro = dzro_1 + dzro_2
+ ro = dzro &
+ / max(epsi, dz)
+ wn = (dzro_1 * etagra(ikl) + dzro_2 * etagrb(ikl)) &
+ / max(epsi, dzro)
+ tn = (dzro_1 * T_agra(ikl) + dzro_2 * T_agrb(ikl)) &
+ / max(epsi, dzro)
+ ag = (dzro_1 * agagra(ikl) + dzro_2 * agagrb(ikl)) &
+ / max(epsi, dzro)
+
+ rh = max(zero, sign(unun, zWEcSV(ikl) &
+ - 0.5 * WEagra(ikl)))
+ nh__OK = rh
+ nh = max(isagra(ikl), isagrb(ikl))
+#if(HB)
+ nh = nh * nh__OK &
+ + (1 - nh__OK) * min(isagra(ikl), isagrb(ikl))
+#endif
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ikl == kSV_v1 .and. lSV_v1 == 3) then
+ write(6, 5995) zWEcSV(ikl), WEagra(ikl) &
+ , isagra(ikl), isagrb(ikl) &
+ , nh__OK, nh
+5995 format(' WE2,WEa =', 2f9.1, ' nha,b =', 2i2, ' nh__OK,nh =', 2i2)
+ endif
+#endif
+
+ ! +-- 2 Nouveaux Types de Grains / new Grain Types
+ ! + -------------------------------------------
+
+ ! +-- 2.1. Meme Type de Neige / same Grain Type
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ SameOK = max(zero, &
+ sign(unun, G1agra(ikl) * G1agrb(ikl) - eps_21))
+ G1same = (dzro_1 * G1agra(ikl) + dzro_2 * G1agrb(ikl)) &
+ / max(epsi, dzro)
+ G2same = (dzro_1 * G2agra(ikl) + dzro_2 * G2agrb(ikl)) &
+ / max(epsi, dzro)
+
+ ! +-- 2.2. Types differents / differents Types
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ typ__1 = max(zero, sign(unun, epsi - G1agra(ikl))) ! =1.=> Dendritic
+ ! ro of Dendr.Lay.
+ zroNEW = typ__1 * dzro_1 &
+ + (1.-typ__1) * dzro_2
+ ! G1 of Dendr.Lay.
+ G1_NEW = typ__1 * G1agra(ikl) &
+ + (1.-typ__1) * G1agrb(ikl)
+ ! G2 of Dendr.Lay.
+ G2_NEW = typ__1 * G2agra(ikl) &
+ + (1.-typ__1) * G2agrb(ikl)
+ ! ro of Spher.Lay.
+ zroOLD = (1.-typ__1) * dzro_1 &
+ + typ__1 * dzro_2
+ ! G1 of Spher.Lay.
+ G1_OLD = (1.-typ__1) * G1agra(ikl) &
+ + typ__1 * G1agrb(ikl)
+ ! G2 of Spher.Lay.
+ G2_OLD = (1.-typ__1) * G2agra(ikl) &
+ + typ__1 * G2agrb(ikl)
+ ! Size Dendr.Lay.
+ SizNEW = -G1_NEW * DDcdSV / G1_dSV &
+ + (1.+G1_NEW / G1_dSV) &
+ * (G2_NEW * DScdSV / G1_dSV &
+ + (1.-G2_NEW / G1_dSV) * DFcdSV)
+ ! Spher.Dendr.Lay.
+ SphNEW = G2_NEW / G1_dSV
+ ! Size Spher.Lay.
+ SizOLD = G2_OLD
+ ! Spher.Spher.Lay.
+ SphOLD = G1_OLD / G1_dSV
+ ! Averaged Size
+ Siz_av = (zroNEW * SizNEW + zroOLD * SizOLD) &
+ / max(epsi, dzro)
+ ! Averaged Sphericity
+ Sph_av = (zroNEW * SphNEW + zroOLD * SphOLD) &
+ / max(epsi, dzro)
+ Den_av = (Siz_av - (Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV)) &
+ / (DDcdSV - (Sph_av * DScdSV &
+ + (1.-Sph_av) * DFcdSV))
+ DendOK = max(zero, &
+ ! Small Grains Contr.
+ sign(unun, Sph_av * DScdSV &
+ ! Faceted Grains Contr.
+ + (1.-Sph_av) * DFcdSV &
+ - Siz_av))!
+ ! +... REMARQUE: le type moyen (dendritique ou non) depend
+ ! + ^^^^^^^^ de la comparaison avec le diametre optique
+ ! + d'une neige recente de dendricite nulle
+ ! +... REMARK: the mean type (dendritic or not) depends
+ ! + ^^^^^^ on the comparaison with the optical diameter
+ ! + of a recent snow having zero dendricity
+
+ G1diff = (-DendOK * Den_av &
+ + (1.-DendOK) * Sph_av) * G1_dSV
+ G2diff = DendOK * Sph_av * G1_dSV &
+ + (1.-DendOK) * Siz_av
+ G1 = SameOK * G1same &
+ + (1.-SameOK) * G1diff
+ G2 = SameOK * G2same &
+ + (1.-SameOK) * G2diff
+
+ ! +--Assignation to new Properties
+ ! + =============================
+
+ isagra(ikl) = Agreg1(ikl) * nh + (1.-Agreg1(ikl)) * isagra(ikl)
+ dzagra(ikl) = Agreg1(ikl) * dz + (1.-Agreg1(ikl)) * dzagra(ikl)
+ T_agra(ikl) = Agreg1(ikl) * tn + (1.-Agreg1(ikl)) * T_agra(ikl)
+ roagra(ikl) = Agreg1(ikl) * ro + (1.-Agreg1(ikl)) * roagra(ikl)
+ etagra(ikl) = Agreg1(ikl) * wn + (1.-Agreg1(ikl)) * etagra(ikl)
+ G1agra(ikl) = Agreg1(ikl) * G1 + (1.-Agreg1(ikl)) * G1agra(ikl)
+ G2agra(ikl) = Agreg1(ikl) * G2 + (1.-Agreg1(ikl)) * G2agra(ikl)
+ agagra(ikl) = Agreg1(ikl) * ag + (1.-Agreg1(ikl)) * agagra(ikl)
+
+ enddo
+
+ return
+endsubroutine SISVAT_zAg
diff --git a/MAR/code_mar/sisvat_zcr.f90 b/MAR/code_mar/sisvat_zcr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2b36c382287092dd1a137cb7997c7d2bc5b0d223
--- /dev/null
+++ b/MAR/code_mar/sisvat_zcr.f90
@@ -0,0 +1,180 @@
+subroutine SISVAT_zCr
+ ! +
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_zCr 12-12-2002 MAR |
+ ! | subroutine SISVAT_zCr determines criteria for Layers Agregation |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT / isnoSV = total Nb of Ice/Snow Layers |
+ ! | OUTPUT: iiceSV = total Nb of Ice Layers |
+ ! | ^^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer |
+ ! | istoSV = 0,...,5 : Snow History (see istdSV data) |
+ ! | |
+ ! | INPUT / ro__SV : Soil/Snow Volumic Mass [kg/m3] |
+ ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] |
+ ! | ^^^^^^ G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+ ! | G2snSV : Sphericity (>0) or Size of Snow Layer |
+ ! | agsnSV : Snow Age [day] |
+ ! | |
+ ! | OUTPUT: LIndsv : Relative Index of a contiguous Layer to agregate |
+ ! | ^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ ! +
+ use marphy
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use marysv
+ ! +
+ implicit none
+ ! +
+ ! +--Internal Variables
+ ! + ==================
+ ! +
+ integer ikl, isn, is0, is1
+ integer isno_1 ! Switch: ! Snow Layer over Ice
+ real Dtyp_0, Dtyp_1 ! Snow Grains Difference Measure
+ real DenSph ! 1. when contiguous spheric
+ ! + ! and dendritic Grains
+ real DendOK ! 1. when dendritic Grains
+ real dTypMx ! Grain Type Differ.
+ real dTypSp ! Sphericity Weight
+ real dTypRo ! Density Weight
+ real dTypDi ! Grain Diam.Weight
+ real dTypHi ! History Weight
+
+ ! +--DATA
+ ! + ====
+
+ data dTypMx/200.0/ ! Grain Type Weight
+ data dTypSp/0.5/ ! Sphericity Weight
+ data dTypRo/0.5/ ! Density Weight
+ data dTypDi/10.0/ ! Grain Diam.Weight
+ data dTypHi/100.0/ ! History Weight
+
+ ! +--Agregation Criteria
+ ! + ===================
+ ! +
+ do ikl = 1, klonv
+ i_thin(ikl) = min(i_thin(ikl), isnoSV(ikl))
+ isn = max(1, i_thin(ikl))
+ ! +
+ ! +
+ ! +--Comparison with the downward Layer
+ ! + ----------------------------------
+ ! +
+ ! Downward Layer Index
+ is0 = max(1, i_thin(ikl) - 1)
+ ! isn/is1 Dendricity/Sphericity Switch
+ DenSph = max(zero, &
+ sign(unun, &
+ epsi - G1snSV(ikl, isn) &
+ * G1snSV(ikl, is0)))
+ ! Dendricity Switch
+ DendOK = max(zero, &
+ sign(unun, &
+ epsi - G1snSV(ikl, isn)))
+ ! +
+ Dtyp_0 = &
+ DenSph * dTypMx &
+ + (1.-DenSph) &
+ ! Dendricity Contribution
+ * DendOK * ((abs(G1snSV(ikl, isn) - G1snSV(ikl, is0)) &
+ ! Sphericity Contribution
+ + abs(G2snSV(ikl, isn) - G2snSV(ikl, is0))) * dTypSp &
+ ! Density Contribution
+ + abs(ro__SV(ikl, isn) - ro__SV(ikl, is0)) * dTypRo) &
+ + (1.-DenSph) &
+ ! Sphericity Contribution
+ * (1.-DendOK) * ((abs(G1snSV(ikl, isn) - G1snSV(ikl, is0)) &
+ ! Size Contribution
+ + abs(G2snSV(ikl, isn) - G2snSV(ikl, is0))) * dTypDi &
+ ! Density Contribution
+ + abs(ro__SV(ikl, isn) - ro__SV(ikl, is0)) * dTypRo)
+ Dtyp_0 = &
+ min(dTypMx, &
+ Dtyp_0 &
+ ! History Contribution
+ + abs(istoSV(ikl, isn) - istoSV(ikl, is0)) * dTypHi) &
+ !"Same Layer"Score
+ + (1 - abs(isn - is0)) * 1.e+6 &
+ !"Ice /Snow Interface" Score
+ + max(0, 1 - abs(iiceSV(ikl) &
+ - is0)) * 1.e+6
+ ! +
+ ! +
+ ! +--Comparison with the upward Layer
+ ! + ----------------------------------
+ ! +
+ ! Upward Layer Index
+ is1 = min(i_thin(ikl) + 1, &
+ max(1, isnoSV(ikl)))
+ ! isn/is1 Dendricity/Sphericity Switch
+ DenSph = max(zero, &
+ sign(unun, &
+ epsi - G1snSV(ikl, isn) &
+ * G1snSV(ikl, is1)))
+ ! Dendricity Switch
+ DendOK = max(zero, &
+ sign(unun, &
+ epsi - G1snSV(ikl, isn)))
+ ! +
+ Dtyp_1 = &
+ DenSph * dTypMx &
+ + (1.-DenSph) &
+ ! Dendricity Contribution
+ * DendOK * ((abs(G1snSV(ikl, isn) &
+ - G1snSV(ikl, is1)) &
+ ! Sphericity Contribution
+ + abs(G2snSV(ikl, isn) - G2snSV(ikl, is1))) * dTypSp &
+ ! Density Contribution
+ + abs(ro__SV(ikl, isn) - ro__SV(ikl, is1)) * dTypRo) &
+ + (1.-DenSph) &
+ ! Sphericity Contribution
+ * (1.-DendOK) * ((abs(G1snSV(ikl, isn) &
+ - G1snSV(ikl, is1)) &
+ ! Size Contribution
+ + abs(G2snSV(ikl, isn) - G2snSV(ikl, is1))) * dTypDi &
+ ! Density Contribution
+ + abs(ro__SV(ikl, isn) - ro__SV(ikl, is1)) * dTypRo)
+ Dtyp_1 = &
+ min(dTypMx, &
+ Dtyp_1 &
+ ! History Contribution
+ + abs(istoSV(ikl, isn) &
+ - istoSV(ikl, is1)) * dTypHi) &
+ !"Same Layer"Score
+ + (1 - abs(isn - is1)) * 1.e+6 &
+ !"Ice /Snow Interface" Score
+ + max(0, 1 - abs(iiceSV(ikl) &
+ - isn)) * 1.e+6
+ ! +
+ ! +
+ ! +--Index of the Layer to agregate
+ ! + ==============================
+ ! +
+ LIndsv(ikl) = sign(unun, Dtyp_0 &
+ - Dtyp_1)
+ ! Switch = 1
+ isno_1 = (1 - min(abs(isnoSV(ikl) &
+ ! if isno = iice +1
+ - iiceSV(ikl) - 1), 1)) &
+ ! Switch = 1
+ * (1 - min(abs(isnoSV(ikl) &
+ ! if isno = i_ithin
+ - i_thin(ikl)), 1))
+ ! Contiguous Layer is
+ LIndsv(ikl) = (1 - isno_1) * LIndsv(ikl) &
+ ! downward for top L.
+ - isno_1
+ i_thin(ikl) = max(1, i_thin(ikl))
+ enddo
+ ! +
+ return
+endsubroutine SISVAT_zCr
diff --git a/MAR/code_mar/sisvat_zsn.f90 b/MAR/code_mar/sisvat_zsn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..75637363cd05f5104ff7a0ef9c69bc5bc0cf3a46
--- /dev/null
+++ b/MAR/code_mar/sisvat_zsn.f90
@@ -0,0 +1,971 @@
+#include "MAR_pp.def"
+subroutine SISVAT_zSn
+ ! +------------------------------------------------------------------------+
+ ! | MAR SISVAT_zSn 02-10-2021 MAR |
+ ! | subroutine SISVAT_zSn manages the Snow Pack vertical Discretization |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | PARAMETERS: klonv: Total Number of columns = |
+ ! | ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! | X Number of Mosaic Cell per grid box |
+ ! | |
+ ! | INPUT / NLaysv = New Snow Layer Switch |
+ ! | OUTPUT: isnoSV = total Nb of Ice/Snow Layers |
+ ! | ^^^^^^ ispiSV = 0,...,nsno: Uppermost Superimposed Ice Layer |
+ ! | iiceSV = total Nb of Ice Layers |
+ ! | istoSV = 0,...,5 : Snow History (see istdSV data) |
+ ! | |
+ ! | INPUT / TsisSV : Soil/Ice Temperatures (layers -nsol,-nsol+1,..,0)|
+ ! | OUTPUT: & Snow Temperatures (layers 1,2,...,nsno) [K] |
+ ! | ^^^^^^ ro__SV : Soil/Snow Volumic Mass [kg/m3] |
+ ! | eta_SV : Soil/Snow Water Content [m3/m3] |
+ ! | dzsnSV : Snow Layer Thickness [m] |
+ ! | G1snSV : Dendricity (<0) or Sphericity (>0) of Snow Layer |
+ ! | G2snSV : Sphericity (>0) or Size of Snow Layer |
+ ! | agsnSV : Snow Age [day] |
+ ! | |
+ ! | METHOD: 1) Agregate the thinest Snow Layer |
+ ! | ^^^^^^ if a new Snow Layer has been precipitated (NLaysv = 1) |
+ ! | 2) Divide a too thick Snow Layer except |
+ ! | if the maximum Number of Layer is reached |
+ ! | in this case forces NLay_s = 1 |
+ ! | 3) Agregate the thinest Snow Layer |
+ ! | in order to divide a too thick Snow Layer |
+ ! | at next Time Step when NLay_s = 1 |
+ ! | |
+ ! | Preprocessing Option: SISVAT IO (not always a standard preprocess.) |
+ ! | ^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^ |
+ ! | FILE | CONTENT |
+ ! | ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+ ! | # SISVAT_zSn.vz | #vz: OUTPUT/Verification: Snow Layers Agrega. |
+ ! | | unit 41, subroutine SISVAT_zSn **ONLY** |
+ ! | # SISVAT_GSn.vp | #vp: OUTPUT/Verification: Snow Properties |
+ ! | | unit 47, subroutines SISVAT_zSn, _GSn |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use mar0sv
+ use marxsv
+ use marysv
+
+ implicit none
+
+ ! +--Internal Variables
+ ! + ==================
+
+ integer ikl, isn, i
+ ! NLay_s : Split Snow Layer Switch
+ integer NLay_s(klonv)
+ ! isagr1 : 1st Layer History
+ integer isagr1(klonv)
+ ! isagr2 : 2nd Layer History
+ integer isagr2(klonv)
+ ! LstLay : 0 -> isnoSV = 1
+ integer LstLay
+ ! isno_n : Snow Normal.Profile
+ integer isno_n
+ ! iice_n : Ice Normal.Profile
+ integer iice_n
+ ! iiceOK : Ice Switch
+ integer iiceOK
+ ! icemix : 0 -> Agregated Snow+Ice=Snow 1 -> Ice
+ integer icemix
+ ! isn1 : 1st layer to stagger
+ integer isn1(klonv)
+ ! staggr : stagger Switch
+ real staggr
+ ! WEagre : Snow Water Equivalent Thickness
+ real WEagre(klonv)
+ ! dzthin : Thickness of the thinest layer
+ real dzthin(klonv)
+ ! OKthin : Swich ON a new thinest layer
+ real OKthin
+ ! dz_dif : difference from ideal discret.
+ real dz_dif
+ ! thickL : Thick Layer Indicator
+ real thickL
+ ! OK_ICE : Swich ON uppermost Ice Layer
+ real OK_ICE
+
+ ! Agrege : 1. when Agregation constrained
+ real Agrege(klonv)
+ ! dzepsi : Min Single Snw Layer Thickness
+ real dzepsi
+ ! dzxmin : Min Acceptable Layer Thickness
+ real dzxmin
+ ! dz_min : Min Layer Thickness
+ real dz_min
+ ! dz_max : Max Layer Thickness
+ real dz_max
+ ! dzagr1 : 1st Layer Thickness
+ real dzagr1(klonv)
+ ! dzagr2 : 2nd Layer Thickness
+ real dzagr2(klonv)
+ ! T_agr1 : 1st Layer Temperature
+ real T_agr1(klonv)
+ ! T_agr2 : 2nd Layer Temperature
+ real T_agr2(klonv)
+ ! roagr1 : 1st Layer Density
+ real roagr1(klonv)
+ ! roagr2 : 2nd Layer Density
+ real roagr2(klonv)
+ ! etagr1 : 1st Layer Water Content
+ real etagr1(klonv)
+ ! etagr2 : 2nd Layer Water Content
+ real etagr2(klonv)
+ ! G1agr1 : 1st Layer Dendricity/Spher.
+ real G1agr1(klonv)
+ ! G1agr2 : 2nd Layer Dendricity/Spher.
+ real G1agr2(klonv)
+ ! G2agr1 : 1st Layer Sphericity/Size
+ real G2agr1(klonv)
+ ! G2agr2 : 2nd Layer Sphericity/Size
+ real G2agr2(klonv)
+ ! agagr1 : 1st Layer Age
+ real agagr1(klonv)
+ ! agagr2 : 2nd Layer Age
+ real agagr2(klonv)
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+ common / SISVAT_EV / iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+#endif
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ ! IO Switch
+ logical as_opn
+ common / SI_zSn_L / as_opn
+ ! Snow Reference Discretization
+ real dz_ref(nsno)
+ real dzwdif(nsno)
+#endif
+
+#if(vp)
+ ! +--Snow Properties Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! IO Switch
+ logical VP_opn
+ common / SI_GSn_L / VP_opn
+#endif
+
+ ! +--DATA
+ ! + ====
+
+ data icemix/0/ ! 0 ====> Agregated Snow+Ice=Snow
+ data dzepsi/0.0020/ ! Min single Layer Thickness
+ data dzxmin/0.0025/ ! Min accept.Layer Thickness
+#if(EU)
+ data dz_min/0.0050/ ! Min Local Layer Thickness < SMn
+#endif
+ data dz_min/0.0040/ ! Min Local Layer Thickness < SMn
+ data dz_max/0.0300/ ! Min Gener. Layer Thickness
+ ! + CAUTION: dz_max > dz_min*2 is required ! Otherwise re-agregation is
+ ! + ! activated after splitting
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + =====================
+ if(.not. as_opn) then
+ as_opn = .true.
+ open(unit=41, status='unknown', file='SISVAT_zSn.vz')
+ rewind 41
+ endif
+#endif
+
+#if(vp)
+ ! +--Snow Properties: IO
+ ! + =====================
+ if(.not. VP_opn) then
+ VP_opn = .true.
+ open(unit=47, status='unknown', file='SISVAT_GSn.vp')
+ rewind 47
+ endif
+#endif
+
+ ! +--Constrains Agregation of too thin Layers
+ ! + ========================================
+
+ ! +--Search the thinest non-zero Layer
+ ! + ---------------------------------
+
+ do ikl = 1, klonv
+
+ if(isnoSV(ikl) <= 2) dz_min = max(0.0050, dz_min)
+
+ dzepsi = 0.0015
+ if(ro__SV(ikl, isnoSV(ikl)) > 920) dzepsi = 0.0020
+
+ dzthin(ikl) = 0. ! Arbitrary unrealistic
+ enddo ! Layer Thickness
+ !XF
+ do ikl = 1, klonv
+ ! no agregation of 3 first snowlayers
+ ! XF 04/07/2019
+ do isn = 1, isnoSV(ikl) - 3
+ isno_n = isnoSV(ikl) - isn + 1 ! Snow Normal.Profile
+ iice_n = iiceSV(ikl) - isn ! Ice Normal.Profile
+ iiceOK = min(1, max(0, iice_n + 1)) ! Ice Switch
+#if(vz)
+ ! Theoretical Profile
+ dz_ref(isn) = &
+ dz_min * ((1 - iiceOK) * isno_n * isno_n &
+ + iiceOK * 2**iice_n) &
+ / max(1, isnoSV(ikl))
+#endif
+ ! Actual Profile
+ dz_dif = max(zero, &
+ ! Theoretical Profile
+ dz_min * ((1 - iiceOK) * isno_n * isno_n &
+ + iiceOK * 2.**iice_n) &
+ ! Actual Profile
+ - dzsnSV(ikl, isn))
+#if(vz)
+ dzwdif(isn) = dz_dif
+#endif
+ OKthin = max(zero, &
+ ! 1.=> New thinest Lay.
+ sign(unun, dz_dif - dzthin(ikl))) &
+ ! 1 => .le. isnoSV => isn is in the Snow Pack
+ * max(0, min(1, isnoSV(ikl) - isn + 1)) &
+ * min(unun, max(zero, &
+ ! combination G1 with same sign => OK
+ sign(unun, G1snSV(ikl, isn) &
+ * G1snSV(ikl, max(1, isn - 1)))) &
+ ! G1>0 => OK
+ + max(zero, sign(unun, G1snSV(ikl, isn))) &
+ ! dz too small => OK
+ + max(zero, sign(unun, dzxmin - dzsnSV(ikl, isn))))
+ ! Update thinest Lay. Index
+ i_thin(ikl) = (1.-OKthin) * i_thin(ikl) + OKthin * isn
+ dzthin(ikl) = (1.-OKthin) * dzthin(ikl) + OKthin * dz_dif
+ enddo
+ enddo
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(41, 4150) daHost, n___SV(lwriSV(1)) &
+ , i_thin(1), dzsnSV(1, i_thin(1))
+4150 format(/, '-', a18, i5, ' ', 70('-'), &
+ /, ' Thinest ', i3, ':', f9.3)
+#endif
+
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ OKthin = max(zero, &
+ ! ON if dz < dz_min and dz > 0
+ sign(unun, dz_min - dzsnSV(ikl, isn))) &
+ * max(zero, sign(unun, dzsnSV(ikl, isn) - epsi)) &
+ ! Multiple Snow Layers
+ * min(1, max(0, &
+ ! Switch = 1 if isno > iice + 1
+ min(1, isnoSV(ikl) - iiceSV(ikl) - 1)) &
+ + int(max(zero, &
+ ! Minimum accepted for 1 Snow Layer over Ice
+ sign(unun, dzepsi - dzsnSV(ikl, isn)))) &
+ ! ON if dz > 0
+ * int(max(zero, sign(unun, dzsnSV(ikl, isn) - epsi))) &
+ ! Switch = 1 if isno = iice + 1
+ * (1 - min(abs(isnoSV(ikl) - iiceSV(ikl) - 1), 1)) &
+ ! Ice Switch
+ + max(0, min(1, iiceSV(ikl) + 1 - isn))) &
+ * min(unun, &
+ ! combination G1>0 + G1<0
+ max(zero, &
+ sign(unun, G1snSV(ikl, isn) * G1snSV(ikl, max(1, isn - 1)))) &
+ + max(zero, sign(unun, G1snSV(ikl, isn))) &
+ + max(zero, sign(unun, dzxmin - dzsnSV(ikl, isn))))
+ ! Update thinest Layer Index
+ i_thin(ikl) = (1.-OKthin) * i_thin(ikl) + OKthin * isn
+ enddo
+ enddo
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(41, 4151) i_thin(1), dzsnSV(1, i_thin(1)) &
+ , isnoSV(1), dzsnSV(1, isnoSV(1))
+4151 format(' Thinest ', i3, ':', f9.3, ' Max =', i3, f12.3)
+#endif
+
+#if(vp)
+ ! +--Snow Properties Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ write(47, 470)(G1snSV(1, isn), isn=1, isnoSV(1))
+470 format('Before _zCr1: G1 = ', 10f8.1,(/, 19x, 10f8.1))
+ write(47, 472)(G2snSV(1, isn), isn=1, isnoSV(1))
+472 format(' G2 = ', 10f8.1,(/, 19x, 10f8.1))
+#endif
+
+ ! +--Index of the contiguous Layer to agregate
+ ! + -----------------------------------------
+ ! + *********
+ call SISVAT_zCr
+ ! + *********
+
+ ! +--Assign the 2 Layers to agregate
+ ! + -------------------------------
+ do ikl = 1, klonv
+ isn = i_thin(ikl)
+ if(LIndsv(ikl) > 0) isn = min(nsno - 1, isn) ! cXF
+ isagr1(ikl) = istoSV(ikl, isn)
+ isagr2(ikl) = istoSV(ikl, isn + LIndsv(ikl))
+ dzagr1(ikl) = dzsnSV(ikl, isn)
+ dzagr2(ikl) = dzsnSV(ikl, isn + LIndsv(ikl))
+ T_agr1(ikl) = TsisSV(ikl, isn)
+ T_agr2(ikl) = TsisSV(ikl, isn + LIndsv(ikl))
+ roagr1(ikl) = ro__SV(ikl, isn)
+ roagr2(ikl) = ro__SV(ikl, isn + LIndsv(ikl))
+ etagr1(ikl) = eta_SV(ikl, isn)
+ etagr2(ikl) = eta_SV(ikl, isn + LIndsv(ikl))
+ G1agr1(ikl) = G1snSV(ikl, isn)
+ G1agr2(ikl) = G1snSV(ikl, isn + LIndsv(ikl))
+ G2agr1(ikl) = G2snSV(ikl, isn)
+ G2agr2(ikl) = G2snSV(ikl, isn + LIndsv(ikl))
+ agagr1(ikl) = agsnSV(ikl, isn)
+ agagr2(ikl) = agsnSV(ikl, isn + LIndsv(ikl))
+ ! 0 if single Layer
+ LstLay = min(1, max(0, isnoSV(ikl) - 1))
+ ! decrement isnoSV if downmost Layer < 1.e-21 m
+ isnoSV(ikl) = isnoSV(ikl) &
+ - (1 - LstLay) * max(zero, &
+ sign(unun, eps_21 - dzsnSV(ikl, 1)))
+ isnoSV(ikl) = max(0, isnoSV(ikl))
+ Agrege(ikl) = max(zero, &
+ ! No Agregation if too thick Layer
+ sign(unun, dz_min - dzagr1(ikl))) &
+ ! if a single Layer
+ * LstLay &
+ ! if Agregation with a Layer above the Pack
+ * min(max(0, isnoSV(ikl) + 1 - i_thin(ikl) - LIndsv(ikl)), 1)
+ WEagre(ikl) = 0.
+ enddo
+
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ WEagre(ikl) = WEagre(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ * min(1, max(0, i_thin(ikl) + 1 - isn))
+ enddo
+ enddo
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(41, 410)
+410 format(/, ' Agregation of too THIN Layers')
+ write(41, 411)(100.*dz_ref(isn), isn=1, nsno)
+ write(41, 412)(100.*dzwdif(isn), isn=1, nsno)
+ write(41, 413)(100.*dzsnSV(1, isn), isn=1, nsno)
+ write(41, 414)(isn, isn=1, nsno)
+411 format(' dz_ref [cm]:', 10f8.2, /,(' ', 10f8.2))
+412 format(' dz_dif [cm]:', 10f8.2, /,(' ', 10f8.2))
+413 format(' dzsnSV [cm]:', 10f8.2, /,(' ', 10f8.2))
+414 format(' ', 10(i5, 3x), /,(' ', 10(i5, 3x)))
+ write(41, 4111) isnoSV(1)
+ write(41, 4112) i_thin(1)
+ write(41, 4113) LIndsv(1)
+ write(41, 4114) Agrege(1)
+ write(41, 4115) 1.e2 * dzagr1(1)
+ write(41, 4116) 1.e2 * dzagr2(1)
+4111 format(' isnoSV :', i8)
+4112 format(' i_thin :', i8)
+4113 format(' LIndsv :', i8)
+4114 format(' Agrege :', f8.2)
+4115 format(' dzagr1 :', f8.2)
+4116 format(' dzagr2 :', f8.2)
+#endif
+
+#if(vp)
+ ! +--Snow Properties Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ write(47, 471)(G1snSV(1, isn), isn=1, isnoSV(1))
+471 format('Before _zAg1: G1 = ', 10f8.1,(/, 19x, 10f8.1))
+ write(47, 472)(G2snSV(1, isn), isn=1, isnoSV(1))
+#endif
+
+ ! +--Agregates
+ ! + ---------
+ ! + **********
+ call SISVAT_zAg(isagr1, isagr2, WEagre &
+ , dzagr1, dzagr2, T_agr1, T_agr2 &
+ , roagr1, roagr2, etagr1, etagr2 &
+ , G1agr1, G1agr2, G2agr1, G2agr2 &
+ , agagr1, agagr2, Agrege)
+ ! + **********
+
+ ! +--Rearranges the Layers
+ ! + ---------------------
+
+ ! +--New (agregated) Snow layer
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isn = i_thin(ikl)
+ isn = min(isn, isn + LIndsv(ikl))
+ isnoSV(ikl) = max(0., isnoSV(ikl) - Agrege(ikl))
+ iiceSV(ikl) = iiceSV(ikl) &
+ - max(0, sign(1, iiceSV(ikl) - isn + icemix)) &
+ * Agrege(ikl) &
+ * max(0, sign(1, iiceSV(ikl) - 1))
+ istoSV(ikl, isn) = (1.-Agrege(ikl)) * istoSV(ikl, isn) &
+ + Agrege(ikl) * isagr1(ikl)
+ dzsnSV(ikl, isn) = (1.-Agrege(ikl)) * dzsnSV(ikl, isn) &
+ + Agrege(ikl) * dzagr1(ikl)
+ TsisSV(ikl, isn) = (1.-Agrege(ikl)) * TsisSV(ikl, isn) &
+ + Agrege(ikl) * T_agr1(ikl)
+ ro__SV(ikl, isn) = (1.-Agrege(ikl)) * ro__SV(ikl, isn) &
+ + Agrege(ikl) * roagr1(ikl)
+ eta_SV(ikl, isn) = (1.-Agrege(ikl)) * eta_SV(ikl, isn) &
+ + Agrege(ikl) * etagr1(ikl)
+ G1snSV(ikl, isn) = (1.-Agrege(ikl)) * G1snSV(ikl, isn) &
+ + Agrege(ikl) * G1agr1(ikl)
+ G2snSV(ikl, isn) = (1.-Agrege(ikl)) * G2snSV(ikl, isn) &
+ + Agrege(ikl) * G2agr1(ikl)
+ agsnSV(ikl, isn) = (1.-Agrege(ikl)) * agsnSV(ikl, isn) &
+ + Agrege(ikl) * agagr1(ikl)
+ enddo
+
+ ! +--Above
+ ! + ^^^^^
+ do ikl = 1, klonv
+ isn1(ikl) = max(i_thin(ikl), i_thin(ikl) + LIndsv(ikl))
+ enddo
+ do i = 1, nsno - 1
+ do ikl = 1, klonv
+ staggr = min(1, max(0, i + 1 - isn1(ikl)))
+ istoSV(ikl, i) = (1.-staggr) * istoSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * istoSV(ikl, i) &
+ + Agrege(ikl) * istoSV(ikl, i + 1))
+ dzsnSV(ikl, i) = (1.-staggr) * dzsnSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * dzsnSV(ikl, i) &
+ + Agrege(ikl) * dzsnSV(ikl, i + 1))
+ TsisSV(ikl, i) = (1.-staggr) * TsisSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * TsisSV(ikl, i) &
+ + Agrege(ikl) * TsisSV(ikl, i + 1))
+ ro__SV(ikl, i) = (1.-staggr) * ro__SV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * ro__SV(ikl, i) &
+ + Agrege(ikl) * ro__SV(ikl, i + 1))
+ eta_SV(ikl, i) = (1.-staggr) * eta_SV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * eta_SV(ikl, i) &
+ + Agrege(ikl) * eta_SV(ikl, i + 1))
+ G1snSV(ikl, i) = (1.-staggr) * G1snSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * G1snSV(ikl, i) &
+ + Agrege(ikl) * G1snSV(ikl, i + 1))
+ G2snSV(ikl, i) = (1.-staggr) * G2snSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * G2snSV(ikl, i) &
+ + Agrege(ikl) * G2snSV(ikl, i + 1))
+ agsnSV(ikl, i) = (1.-staggr) * agsnSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * agsnSV(ikl, i) &
+ + Agrege(ikl) * agsnSV(ikl, i + 1))
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ isn = min(isnoSV(ikl) + 1, nsno)
+ istoSV(ikl, isn) = (1.-Agrege(ikl)) * istoSV(ikl, isn)
+ dzsnSV(ikl, isn) = (1.-Agrege(ikl)) * dzsnSV(ikl, isn)
+ TsisSV(ikl, isn) = (1.-Agrege(ikl)) * TsisSV(ikl, isn)
+ ro__SV(ikl, isn) = (1.-Agrege(ikl)) * ro__SV(ikl, isn)
+ eta_SV(ikl, isn) = (1.-Agrege(ikl)) * eta_SV(ikl, isn)
+ G1snSV(ikl, isn) = (1.-Agrege(ikl)) * G1snSV(ikl, isn)
+ G2snSV(ikl, isn) = (1.-Agrege(ikl)) * G2snSV(ikl, isn)
+ agsnSV(ikl, isn) = (1.-Agrege(ikl)) * agsnSV(ikl, isn)
+ enddo
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ikl == kSV_v1 .and. lSV_v1 == 3) then
+ write(6, 5991) i_thin(ikl)
+5991 format(/, 'First Agregation / Layer', i3, &
+ /, ' i', 11x, 'T', 9x, 'rho', 10x, 'dz', 11x, 'H')
+ write(6, 5995)(isn, TsisSV(ikl, isn), ro__SV(ikl, isn) &
+ , dzsnSV(ikl, isn), istoSV(ikl, isn), &
+ isn=isnoSV(ikl), 1, -1)
+5995 format(i3, 3f12.3, i12)
+ endif
+#endif
+
+ ! +--Constrains Splitting of too thick Layers
+ ! + ========================================
+
+ ! +--Search the thickest non-zero Layer
+ ! + ----------------------------------
+
+ do ikl = 1, klonv
+ ! Arbitrary unrealistic
+ dzthin(ikl) = 0.
+ enddo
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ ! Snow Normal.Profile
+ isno_n = isnoSV(ikl) - isn + 1
+ ! Ice Normal.Profile
+ iice_n = iiceSV(ikl) - isn
+ ! Ice Switch
+ iiceOK = min(1, max(0, iice_n + 1))
+ ! Actual Profile
+ dz_dif = (dzsnSV(ikl, isn) &
+ ! Theoretical Profile
+ - dz_max * ((1 - iiceOK) * isno_n * isno_n &
+ + iiceOK * 2.**iice_n)) &
+ / max(dzsnSV(ikl, isn), epsi)
+ OKthin = max(zero, &
+ sign(unun, &
+ ! 1.=>New thickest Lay.
+ dz_dif - dzthin(ikl))) &
+ ! 1 =>.le. isnoSV
+ * max(0, &
+ min(1, &
+ isnoSV(ikl) - isn + 1))
+ ! Update thickest Lay. Index
+ i_thin(ikl) = (1.-OKthin) * i_thin(ikl) &
+ + OKthin * isn
+ dzthin(ikl) = (1.-OKthin) * dzthin(ikl) &
+ + OKthin * dz_dif
+ enddo
+
+ isn = 1
+ if(isnoSV(ikl) > 1 .and. dzsnSV(ikl, isn) > 5) then
+ ! layer > 5m
+ i_thin(ikl) = isn
+ dzthin(ikl) = dzsnSV(ikl, isn)
+ endif
+
+ isn = 2
+ if(isnoSV(ikl) > 2 .and. dzsnSV(ikl, isn) > 5) then
+ ! layer > 5m
+ i_thin(ikl) = isn
+ dzthin(ikl) = dzsnSV(ikl, isn)
+ endif
+
+ isn = max(1, isnoSV(ikl) - 3)
+ ! surface layer > 30cm ! XF 04/07/2019
+ if(dzsnSV(ikl, isn) > 0.30) then
+ i_thin(ikl) = isn
+ dzthin(ikl) = dzsnSV(ikl, isn)
+ endif
+
+ isn = max(1, isnoSV(ikl) - 2)
+ ! surface layer > 10cm ! XF 04/07/2019
+ if(dzsnSV(ikl, isn) > 0.10) then
+ i_thin(ikl) = isn
+ dzthin(ikl) = dzsnSV(ikl, isn)
+ endif
+
+ isn = max(1, isnoSV(ikl) - 1)
+ ! surface layer > 5cm ! XF 04/07/2019
+ if(dzsnSV(ikl, isn) > 0.05) then
+ i_thin(ikl) = isn
+ dzthin(ikl) = dzsnSV(ikl, isn)
+ endif
+
+ isn = max(1, isnoSV(ikl))
+ ! surface layer > 2cm ! XF 04/07/2019
+ if(dzsnSV(ikl, isn) > 0.02) then
+ i_thin(ikl) = isn
+ dzthin(ikl) = dzsnSV(ikl, isn)
+ endif
+
+ enddo
+
+ do ikl = 1, klonv
+ ! 1. => a too thick Layer exists
+ ThickL = max(zero, &
+ sign(unun, dzthin(ikl) &
+ - epsi)) &
+ ! No spliting allowed if isno > nsno - 1
+ * max(0, 1 - max(0, isnoSV(ikl) &
+ - nsno + 1))
+ ! 1. => effective split
+ Agrege(ikl) = ThickL &
+ * max(0, 1 - max(0, NLaysv(ikl) &
+ + isnoSV(ikl) &
+ - nsno + 1))
+ ! Agregation to allow Splitting at next Time Step
+ NLay_s(ikl) = ThickL &
+ * max(0, 1 - max(0, NLaysv(ikl) &
+ + isnoSV(ikl) &
+ - nsno)) &
+ - Agrege(ikl)
+ ! Agregation effective
+ NLay_s(ikl) = max(0, NLay_s(ikl))
+ enddo
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(41, 4152) i_thin(1), dzthin(1), ThickL
+4152 format(/, ' Thickest', i3, ':', f9.3, ' Split =', f4.0)
+#endif
+
+ ! +--Rearranges the Layers
+ ! + ---------------------
+
+ do isn = nsno, 2, -1
+ do ikl = 1, klonv
+ if(Agrege(ikl) > 0. .and. i_thin(ikl) < isnoSV(ikl)) then
+ staggr = min(1, max(0, isn - i_thin(ikl) - 1)) &
+ * min(1, max(0, isnoSV(ikl) - isn + 2))
+ istoSV(ikl, isn) = staggr * istoSV(ikl, isn - 1) &
+ + (1.-staggr) * istoSV(ikl, isn)
+ dzsnSV(ikl, isn) = staggr * dzsnSV(ikl, isn - 1) &
+ + (1.-staggr) * dzsnSV(ikl, isn)
+ TsisSV(ikl, isn) = staggr * TsisSV(ikl, isn - 1) &
+ + (1.-staggr) * TsisSV(ikl, isn)
+ ro__SV(ikl, isn) = staggr * ro__SV(ikl, isn - 1) &
+ + (1.-staggr) * ro__SV(ikl, isn)
+ eta_SV(ikl, isn) = staggr * eta_SV(ikl, isn - 1) &
+ + (1.-staggr) * eta_SV(ikl, isn)
+ G1snSV(ikl, isn) = staggr * G1snSV(ikl, isn - 1) &
+ + (1.-staggr) * G1snSV(ikl, isn)
+ G2snSV(ikl, isn) = staggr * G2snSV(ikl, isn - 1) &
+ + (1.-staggr) * G2snSV(ikl, isn)
+ agsnSV(ikl, isn) = staggr * agsnSV(ikl, isn - 1) &
+ + (1.-staggr) * agsnSV(ikl, isn)
+ endif
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ isn = i_thin(ikl)
+ dzsnSV(ikl, isn) = 0.5 * Agrege(ikl) * dzsnSV(ikl, isn) &
+ + (1.-Agrege(ikl)) * dzsnSV(ikl, isn)
+
+ isn = min(i_thin(ikl) + 1, nsno)
+ istoSV(ikl, isn) = Agrege(ikl) * istoSV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * istoSV(ikl, isn)
+ dzsnSV(ikl, isn) = Agrege(ikl) * dzsnSV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * dzsnSV(ikl, isn)
+ TsisSV(ikl, isn) = Agrege(ikl) * TsisSV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * TsisSV(ikl, isn)
+ ro__SV(ikl, isn) = Agrege(ikl) * ro__SV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * ro__SV(ikl, isn)
+ eta_SV(ikl, isn) = Agrege(ikl) * eta_SV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * eta_SV(ikl, isn)
+ G1snSV(ikl, isn) = Agrege(ikl) * G1snSV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * G1snSV(ikl, isn)
+ G2snSV(ikl, isn) = Agrege(ikl) * G2snSV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * G2snSV(ikl, isn)
+ agsnSV(ikl, isn) = Agrege(ikl) * agsnSV(ikl, isn - 1) &
+ + (1.-Agrege(ikl)) * agsnSV(ikl, isn)
+ isnoSV(ikl) = min(Agrege(ikl) + isnoSV(ikl), real(nsno))
+ iiceSV(ikl) = iiceSV(ikl) &
+ + Agrege(ikl) * max(0, sign(1, iiceSV(ikl) &
+ - isn + icemix)) &
+ * max(0, sign(1, iiceSV(ikl) &
+ - 1))
+ enddo
+
+ ! +--Constrains Agregation in case of too much Layers
+ ! + =================================================
+
+ ! +--Search the thinest non-zero Layer
+ ! + -----------------------------------
+
+#if(La)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(6, *) ' '
+ write(6, *) 'Agregation 2'
+ write(6, 6000) NLaysv(1)
+6000 format(i3, 6x, &
+ 'dzsnSV dz_min dz_dif ', &
+ 'OKthin dzthin i_thin')
+#endif
+
+ do ikl = 1, klonv
+ ! Arbitrary unrealistic Layer Thickness
+ dzthin(ikl) = 0.
+ enddo
+ do ikl = 1, klonv
+ ! no agregation of 3 first snowlayers ! XF 04/07/2019
+ do isn = 1, isnoSV(ikl) - 3
+ ! Snow Normal.Profile
+ isno_n = isnoSV(ikl) - isn + 1
+ ! Ice Normal.Profile
+ iice_n = iiceSV(ikl) - isn
+ ! Ice Switch
+ iiceOK = min(1, max(0, iice_n + 1))
+#if(vz)
+ ! Theoretical Profile
+ dz_ref(isn) = &
+ dz_min * ((1 - iiceOK) * isno_n * isno_n &
+ + iiceOK * 2**iice_n) &
+ / max(1, isnoSV(ikl))
+#endif
+ ! Actual Profile
+ dz_dif = dz_min &
+ - dzsnSV(ikl, isn) &
+ ! Theoretical Profile
+ / max(epsi,((1 - iiceOK) * isno_n * isno_n &
+ + iiceOK * 2.**iice_n))
+#if(vz)
+ dzwdif(isn) = dz_dif
+#endif
+ OKthin = max(zero, &
+ sign(unun, &
+ ! 1.=> New thinest Lay.
+ dz_dif - dzthin(ikl))) &
+ ! 1 => .le. isnoSV
+ * max(0, &
+ min(1, &
+ isnoSV(ikl) - isn + 1))
+ ! Update thinest Lay. Index
+ i_thin(ikl) = (1.-OKthin) * i_thin(ikl) &
+ + OKthin * isn
+ dzthin(ikl) = (1.-OKthin) * dzthin(ikl) &
+ + OKthin * dz_dif
+
+#if(La)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ if(isn <= isnoSV(1) .and. ikl == 1) &
+ write(6, 6001) isn, dzsnSV(ikl, isn), dz_min * isno_n * isno_n, dz_dif &
+ , OKthin, dzthin(ikl), i_thin(ikl)
+6001 format(i3, 5f12.6, i9)
+#endif
+ enddo
+ enddo
+
+#if(La)
+ write(6, *) ' '
+#endif
+
+#if(vz)
+ write(41, 4153) i_thin(1), dzsnSV(1, i_thin(1))
+4153 format(/, ' Thinest ', i3, ':', f9.3)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(41, 4151) i_thin(1), dzsnSV(1, i_thin(1)) &
+ , isnoSV(1), dzsnSV(1, isnoSV(1))
+#endif
+
+#if(vp)
+ ! +--Snow Properties Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ write(47, 473)(G1snSV(1, isn), isn=1, isnoSV(1))
+473 format('Before _zCr2: G1 = ', 10f8.1,(/, 19x, 10f8.1))
+ write(47, 472)(G2snSV(1, isn), isn=1, isnoSV(1))
+#endif
+
+ ! +--Index of the contiguous Layer to agregate
+ ! + -----------------------------------------
+
+ ! + *********
+ call SISVAT_zCr
+ ! + *********
+
+ ! +--Assign the 2 Layers to agregate
+ ! + -------------------------------
+
+ do ikl = 1, klonv
+ isn = i_thin(ikl)
+ if(LIndsv(ikl) > 0) isn = min(isn, nsno - 1) !cXF
+ isagr1(ikl) = istoSV(ikl, isn)
+ isagr2(ikl) = istoSV(ikl, isn + LIndsv(ikl))
+ dzagr1(ikl) = dzsnSV(ikl, isn)
+ dzagr2(ikl) = dzsnSV(ikl, isn + LIndsv(ikl))
+ T_agr1(ikl) = TsisSV(ikl, isn)
+ T_agr2(ikl) = TsisSV(ikl, isn + LIndsv(ikl))
+ roagr1(ikl) = ro__SV(ikl, isn)
+ roagr2(ikl) = ro__SV(ikl, isn + LIndsv(ikl))
+ etagr1(ikl) = eta_SV(ikl, isn)
+ etagr2(ikl) = eta_SV(ikl, isn + LIndsv(ikl))
+ G1agr1(ikl) = G1snSV(ikl, isn)
+ G1agr2(ikl) = G1snSV(ikl, isn + LIndsv(ikl))
+ G2agr1(ikl) = G2snSV(ikl, isn)
+ G2agr2(ikl) = G2snSV(ikl, isn + LIndsv(ikl))
+ agagr1(ikl) = agsnSV(ikl, isn)
+ agagr2(ikl) = agsnSV(ikl, isn + LIndsv(ikl))
+ LstLay = min(1, max(0, isnoSV(ikl) - 1))
+ Agrege(ikl) = min(1, &
+ max(0, &
+ NLaysv(ikl) + isnoSV(ikl) - nsno &
+ + NLay_s(ikl)) &
+ * LstLay)
+
+ if(isnoSV(ikl) > 3) then
+ ! surface layers> 2-5-10 ! XF 04/07/2019
+ if(dzsnSV(ikl, max(1, isnoSV(ikl) - 0)) > 0.02 .or. &
+ dzsnSV(ikl, max(1, isnoSV(ikl) - 1)) > 0.05 .or. &
+ dzsnSV(ikl, max(1, isnoSV(ikl) - 2)) > 0.10 .or. &
+ dzsnSV(ikl, max(1, isnoSV(ikl) - 3)) > 0.30 .or. &
+ dzsnSV(ikl, 1) > 5. .or. dzsnSV(ikl, 2) > 5.) then
+ Agrege(ikl) = min(1, &
+ ! nsno-1 layers ma
+ max(0, NLaysv(ikl) + isnoSV(ikl) + 1 - nsno &
+ + NLay_s(ikl)) * LstLay)
+ endif
+ endif
+
+ isnoSV(ikl) = isnoSV(ikl) &
+ - (1 - LstLay) * max(zero, &
+ sign(unun, eps_21 &
+ - dzsnSV(ikl, 1)))
+ isnoSV(ikl) = max(0, isnoSV(ikl))
+
+ WEagre(ikl) = 0.
+ enddo
+
+ do isn = 1, nsno
+ do ikl = 1, klonv
+ WEagre(ikl) = WEagre(ikl) + ro__SV(ikl, isn) * dzsnSV(ikl, isn) &
+ * min(1, max(0, i_thin(ikl) + 1 - isn))
+ enddo
+ enddo
+
+#if(vz)
+ ! +--Layers Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~
+ write(41, 4120)
+4120 format(' Agregation of too MUCH Layers')
+ write(41, 411)(100.*dz_ref(isn), isn=1, nsno)
+ write(41, 412)(100.*dzwdif(isn), isn=1, nsno)
+ write(41, 413)(100.*dzsnSV(1, isn), isn=1, nsno)
+ write(41, 414)(isn, isn=1, nsno)
+ write(41, 4111) isnoSV(1)
+ write(41, 4112) i_thin(1)
+ write(41, 4113) LIndsv(1)
+ write(41, 4114) Agrege(1)
+#endif
+
+#if(vp)
+ ! +--Snow Properties Agregation: IO
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ write(47, 474)(G1snSV(1, isn), isn=1, isnoSV(1))
+474 format('Before _zAg2: G1 = ', 10f8.1,(/, 19x, 10f8.1))
+ write(47, 472)(G2snSV(1, isn), isn=1, isnoSV(1))
+#endif
+
+ ! +--Agregates
+ ! + ---------
+
+ ! + ***************
+ call SISVAT_zAg &
+ (isagr1, isagr2, WEagre &
+ , dzagr1, dzagr2, T_agr1, T_agr2 &
+ , roagr1, roagr2, etagr1, etagr2 &
+ , G1agr1, G1agr2, G2agr1, G2agr2 &
+ , agagr1, agagr2, Agrege &
+ )
+ ! + ***************
+
+ ! +--Rearranges the Layers
+ ! + ---------------------
+
+ ! +--New (agregated) Snow layer
+ ! + ^^^^^^^^^^^^^^^^^^^^^^^^^^
+ do ikl = 1, klonv
+ isn = i_thin(ikl)
+ isn = min(isn, isn + LIndsv(ikl))
+ isnoSV(ikl) = max(0., isnoSV(ikl) - Agrege(ikl))
+ iiceSV(ikl) = iiceSV(ikl) &
+ - max(0, sign(1, iiceSV(ikl) - isn + icemix)) &
+ * Agrege(ikl) &
+ * max(0, sign(1, iiceSV(ikl) - 1))
+ istoSV(ikl, isn) = (1.-Agrege(ikl)) * istoSV(ikl, isn) &
+ + Agrege(ikl) * isagr1(ikl)
+ dzsnSV(ikl, isn) = (1.-Agrege(ikl)) * dzsnSV(ikl, isn) &
+ + Agrege(ikl) * dzagr1(ikl)
+ TsisSV(ikl, isn) = (1.-Agrege(ikl)) * TsisSV(ikl, isn) &
+ + Agrege(ikl) * T_agr1(ikl)
+ ro__SV(ikl, isn) = (1.-Agrege(ikl)) * ro__SV(ikl, isn) &
+ + Agrege(ikl) * roagr1(ikl)
+ eta_SV(ikl, isn) = (1.-Agrege(ikl)) * eta_SV(ikl, isn) &
+ + Agrege(ikl) * etagr1(ikl)
+ G1snSV(ikl, isn) = (1.-Agrege(ikl)) * G1snSV(ikl, isn) &
+ + Agrege(ikl) * G1agr1(ikl)
+ G2snSV(ikl, isn) = (1.-Agrege(ikl)) * G2snSV(ikl, isn) &
+ + Agrege(ikl) * G2agr1(ikl)
+ agsnSV(ikl, isn) = (1.-Agrege(ikl)) * agsnSV(ikl, isn) &
+ + Agrege(ikl) * agagr1(ikl)
+ enddo
+
+ ! +--Above
+ ! + ^^^^^
+ do ikl = 1, klonv
+ isn1(ikl) = max(i_thin(ikl), i_thin(ikl) + LIndsv(ikl))
+ enddo
+ do i = 1, nsno - 1
+ do ikl = 1, klonv
+ staggr = min(1, max(0, i + 1 - isn1(ikl)))
+ istoSV(ikl, i) = (1.-staggr) * istoSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * istoSV(ikl, i) &
+ + Agrege(ikl) * istoSV(ikl, i + 1))
+ dzsnSV(ikl, i) = (1.-staggr) * dzsnSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * dzsnSV(ikl, i) &
+ + Agrege(ikl) * dzsnSV(ikl, i + 1))
+ TsisSV(ikl, i) = (1.-staggr) * TsisSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * TsisSV(ikl, i) &
+ + Agrege(ikl) * TsisSV(ikl, i + 1))
+ ro__SV(ikl, i) = (1.-staggr) * ro__SV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * ro__SV(ikl, i) &
+ + Agrege(ikl) * ro__SV(ikl, i + 1))
+ eta_SV(ikl, i) = (1.-staggr) * eta_SV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * eta_SV(ikl, i) &
+ + Agrege(ikl) * eta_SV(ikl, i + 1))
+ G1snSV(ikl, i) = (1.-staggr) * G1snSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * G1snSV(ikl, i) &
+ + Agrege(ikl) * G1snSV(ikl, i + 1))
+ G2snSV(ikl, i) = (1.-staggr) * G2snSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * G2snSV(ikl, i) &
+ + Agrege(ikl) * G2snSV(ikl, i + 1))
+ agsnSV(ikl, i) = (1.-staggr) * agsnSV(ikl, i) &
+ + staggr * ((1.-Agrege(ikl)) * agsnSV(ikl, i) &
+ + Agrege(ikl) * agsnSV(ikl, i + 1))
+ enddo
+ enddo
+
+ do ikl = 1, klonv
+ isn = min(isnoSV(ikl) + 1, nsno)
+ istoSV(ikl, isn) = (1.-Agrege(ikl)) * istoSV(ikl, isn)
+ dzsnSV(ikl, isn) = (1.-Agrege(ikl)) * dzsnSV(ikl, isn)
+ TsisSV(ikl, isn) = (1.-Agrege(ikl)) * TsisSV(ikl, isn)
+ ro__SV(ikl, isn) = (1.-Agrege(ikl)) * ro__SV(ikl, isn)
+ eta_SV(ikl, isn) = (1.-Agrege(ikl)) * eta_SV(ikl, isn)
+ G1snSV(ikl, isn) = (1.-Agrege(ikl)) * G1snSV(ikl, isn)
+ G2snSV(ikl, isn) = (1.-Agrege(ikl)) * G2snSV(ikl, isn)
+ agsnSV(ikl, isn) = (1.-Agrege(ikl)) * agsnSV(ikl, isn)
+ enddo
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(kSV_v1 > 0 .and. lSV_v1 == 3) then
+ write(6, 5992) i_thin(kSV_v1)
+5992 format(/, 'Secnd Agregation / Layer', i3, &
+ /, ' i', 11x, 'T', 9x, 'rho', 10x, 'dz', 11x, 'H')
+ write(6, 5995)(isn, TsisSV(kSV_v1, isn), ro__SV(kSV_v1, isn) &
+ , dzsnSV(kSV_v1, isn), istoSV(kSV_v1, isn), &
+ isn=isnoSV(kSV_v1), 1, -1)
+ endif
+#endif
+
+#if(vp)
+ write(47, 475)(G1snSV(1, isn), isn=1, isnoSV(1))
+475 format('At End _zSn : G1 = ', 10f8.1,(/, 19x, 10f8.1))
+ write(47, 472)(G2snSV(1, isn), isn=1, isnoSV(1))
+#endif
+
+ ! +--Search new Ice/Snow Interface
+ ! + =============================
+ do ikl = 1, klonv
+ iiceSV(ikl) = 0
+ enddo
+ do ikl = 1, klonv
+ do isn = 1, isnoSV(ikl)
+ OK_ICE = max(zero, sign(unun, ro__SV(ikl, isn) - ro_ice + 20.)) &
+ * max(zero, sign(unun, dzsnSV(ikl, isn) - epsi))
+ iiceSV(ikl) = (1.-OK_ICE) * iiceSV(ikl) + OK_ICE * isn
+ enddo
+ enddo
+
+ return
+end
diff --git a/MAR/code_mar/sisvatesbl.f90 b/MAR/code_mar/sisvatesbl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3337a8df094a50c7c453e9b87e35418c124fafdd
--- /dev/null
+++ b/MAR/code_mar/sisvatesbl.f90
@@ -0,0 +1,750 @@
+#include "MAR_pp.def"
+subroutine SISVATeSBL
+ !--------------------------------------------------------------------------+
+ ! MAR SISVATeSBL Tue 12-JUL-2019 MAR |
+ ! subroutine SISVATeSBL generates Surface Boundary Layers Properties |
+ ! (and computes usthSV since 24-sep 2018) |
+ !--------------------------------------------------------------------------+
+ ! |
+ ! PARAMETERS: klonv: Total Number of columns |
+ ! ^^^^^^^^^^ = Total Number of continental grid boxes |
+ ! X Number of Mosaic Cell per grid box |
+ ! |
+ ! INPUT: za__SV : Surface Boundary Layer (SBL) Height [m] |
+ ! ^^^^^ VV__SV :(SBL Top) Wind Velocity [m/s] |
+ ! TaT_SV : SBL Top Temperature [K] |
+ ! ExnrSV : Exner Potential [-] |
+ ! qsnoSV : SBL Mean Snow Content [kg/kg] |
+ ! uqs_SV : Specific Humidity Turbulent Flux [m/s] |
+ ! usthSV : Threshd. friction velocity for snow erosion[m/s] |
+ ! Z0m_SV : Momentum Roughness Length [m] |
+ ! Z0h_SV : Heat Roughness Length [m] |
+ ! Tsrfsv : Surface Temperature [K] |
+ ! sqrCm0 : Contribution of Z0m to Neutral Drag Coefficient |
+ ! sqrCh0 : Contribution of Z0h to Neutral Drag Coefficient |
+ ! |
+ ! INPUT / LMO_SV : Monin-Obukhov Scale [m] |
+ ! OUTPUT: us__SV : Friction Velocity [m/s] |
+ ! ^^^^^^ uts_SV : Temperature Turbulent Flux [K.m/s] |
+ ! uss_SV : Blowing Snow Turbulent Flux [m/s] |
+ ! |
+ ! OUTPUT: hSalSV : Saltating Layer Height [m] |
+ ! ^^^^^^ qSalSV : Saltating Snow Concentration [kg/kg] |
+ ! ram_sv : Aerodynamic Resistance for Momentum [s/m] |
+ ! rah_sv : Aerodynamic Resistance for Heat [s/m] |
+ ! |
+ ! # OPTIONS: #BS: Blowing Snow turbulent Fluxes are computed |
+ ! # ^^^^^^^ #ss: Additional Output |
+ ! |
+ !--------------------------------------------------------------------------+
+
+ use marphy
+ use mar_sv
+ use mardsv
+ use marxsv
+ use marysv
+
+ implicit none
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+ common / SISVAT_EV / iSV_v1, jSV_v1, nSV_v1, kSV_v1, lSV_v1
+#endif
+
+ ! V, dT(a-s) Time Moving Averages
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ integer ntaver, nt
+ parameter(ntaver=4)
+ real V__mem(klonv, ntaver)
+ real VVmmem(klonv)
+ common / SVeSBLmem / V__mem, VVmmem
+ real T__mem(klonv, ntaver)
+ real dTmmem(klonv)
+ common / STeSBLmem / T__mem, dTmmem
+
+ !$OMP threadprivate(/SVeSBLmem/,/STeSBLmem/)
+
+#if(AM)
+ ! u*, u*T*, u*s* Time Moving Averages
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ real u__mem(klonv, ntaver)
+ common / S_eSBLmem / u__mem
+#endif
+#if(AT)
+ real uT_mem(klonv, ntaver)
+ common uT_mem
+#endif
+#if(AS)
+ real us_mem(klonv, ntaver)
+ common us_mem
+#endif
+
+ ! Internal Variables
+ ! ==================
+ integer ikl, icount, isn
+ real VVaSBL(klonv), VVa_OK ! VVaSBL, VVa_OK : effective SBL wind speed
+ real dTa_Ts(klonv) ! dTa_Ts : effective SBL Temperature diff.
+ real Theta0 ! Theta0 : Potential Reference Temperature
+ real LMOmom(klonv) ! LMOmom : Monin-Obukhov Scale Momentum
+ real LMOsgn ! LMOsgn : Monin-Obukhov Scale Sign
+ real LMOabs ! LMOabs : Monin-Obukhov Scale Abs.Value
+ real uustar, thstar, qqstar, ssstar, thstarv, thstars, thstara
+ real zetam, zetah, zeta_S, zeta_A, zeta0m, zeta0h
+ real psim_s, xpsimi, psim_i, psim_z
+ real psis_s, psis_z, psis_0
+ real psih_s, xpsihi, psih_i, psih_z
+ real psim_0, psih_0
+ real CDm(klonv) ! CDm : Drag Coefficient, Momentum
+ real CDs(klonv), rCDs(klonv) ! CDs, rCDs : Drag Coefficient, Blown **
+ real CDh(klonv) ! CDh : Drag Coefficient, Scalar
+ real dustar, u0star, uTstar, usstar
+ real sss__F, sss__N, usuth0
+ real zetMAX
+ real coef_m, coef_h, stab_s
+ real Richar(klonv) ! Richar : Richardson Number
+#if(wr)
+ real W_pLMO ! W_pLMO : Pseudo Obukhov Length (WRITE)
+ real W_psim ! W_psim : Pseudo psim(z) (WRITE)
+#endif
+#if(w1)
+ real W_NUs1 ! W_NUs1 : Contrib to U* numerat.1(WRITE)
+ real W_NUs2 ! W_NUs2 : Contrib to U* numerat.2(WRITE)
+ real W_NUs3 ! W_NUs3 : Contrib to U* numerat.3(WRITE)
+ real W_DUs1 ! W_DUs1 : Contrib to U* denomin.1(WRITE)
+ real W_DUs2 ! W_DUs2 : Contrib to U* denomin.2(WRITE)
+#endif
+ real fac_Ri, vuzvun, Kz_vun
+ character * 3 qsalt_param ! qsalt_param : Switch for saltation flux param.
+ character * 3 usth_param ! usth_param : Switch for u*t param
+
+#if(AE)
+ integer nit, iit
+ real dusuth, signus
+ real sss__K, sss__G
+ real us_127, us_227, us_327, us_427, us_527
+ real SblPom
+ ! rCd10n : Square root of drag coefficient
+ real rCd10n
+ ! DendOK : Dendricity Switch
+ real DendOK
+ ! SaltOK : Saltation Switch
+ real SaltOK
+ ! MeltOK : Saltation Switch (Melting Snow)
+ real MeltOK
+ ! SnowOK : Pack Top Switch
+ real SnowOK
+ ! SaltM1, SaltM2, SaltMo, SaltMx : Saltation Parameters
+ real SaltM1, SaltM2, SaltMo, SaltMx
+ ! ShearX, ShearS : Arg. Max Shear Stress
+ real ShearX, ShearS
+ ! Por_BS : Snow Porosity
+ real Por_BS
+ ! Salt_us : New thresh.friction velocity u*t
+ real Salt_us
+ ! Fac_Mo, ArguSi, FacRho : Numerical factors for u*t
+ real Fac_Mo, ArguSi, FacRho
+ ! SaltSI : Snow Drift Index !
+ real SaltSI(klonv, 0:nsno)
+ ! MIN_Mo : Minimum Mobility Fresh Fallen *
+ real MIN_Mo
+#endif
+
+ ! Internal DATA
+ ! =============
+
+ ! Theta0 : Potential Reference Temperature
+ data Theta0/288.0/
+#if(ZX)
+ ! zetMAX : Strong Stability Limit
+ data zetMAX/1.e6/
+#endif
+#if(zx)
+ ! zetMAX : Strong Stability Limit (Mahalov et al. 2004, GRL 31 2004GL021055)
+ data zetMAX/1.e0/
+#endif
+ ! zetMAX : Strong Stability Limit
+ data zetMAX/4.28/
+ ! coef_m : Stabil.Funct.for Moment.: unstab.coef.
+ ! (King et al. 1996, JGR 101(7) p.19121)
+ data coef_m/20./
+ ! coef_h : Stabil.Funct.for Heat: unstab.coef.
+ data coef_h/15./
+#if(AE)
+ ! Lower Boundary Height Parameter for Suspension
+ ! Pommeroy, Gray and Landine 1993, J. Hydrology, 144(8) p.169
+ ! SblPom : us(is0,uth) recursivity: Nb Iterations
+ data SblPom/1.27/
+ ! nit : saltation part. conc. from Pomeroy and Gray
+ data nit/5/
+ ! qsalt_param : u*t from Gallee et al. 2001
+ ! data qsalt_param/"bin"/ ! saltation part. conc. from Bintanja 2001 (p
+ data qsalt_param/"pom"/
+ ! data usth_param/"lis"/ ! u*t from Liston et al. 2007
+ data usth_param/"gal"/
+ data SaltMx/-5.83e-2/
+ ! +--Computation of threshold friction velocity for snow erosion
+ ! + ===========================================================
+ rCd10n = 1./26.5 ! Vt / u*t = 26.5
+ ! Budd et al. 1965, Antarct. Res. Series Fig.13
+ ! ratio developped during assumed neutral conditions
+ ! +--Snow Properties
+ ! + ~~~~~~~~~~~~~~~
+ ! do isn = 1, nsno
+ do ikl = 1, klonv
+ isn = isnoSV(ikl)
+ DendOK = max(zero, sign(unun, epsi - G1snSV(ikl, isn)))
+ SaltOK = min(1, max(istdSV(2) - istoSV(ikl, isn), 0))
+ MeltOK = (unun &
+ - max(zero, sign(unun, TfSnow - epsi &
+ - TsisSV(ikl, isn)))) &
+ * min(unun, DendOK &
+ + (1.-DendOK) &
+ ! 1.0 for 1mm
+ * sign(unun, G2snSV(ikl, isn) - 1.0))
+ ! Snow Switch
+ SnowOK = min(1, max(isnoSV(ikl) + 1 - isn, 0))
+ G1snSV(ikl, isn) = SnowOK * G1snSV(ikl, isn) &
+ + (1.-SnowOK) * min(G1snSV(ikl, isn), G1_dSV)
+ G2snSV(ikl, isn) = SnowOK * G2snSV(ikl, isn) &
+ + (1.-SnowOK) * min(G2snSV(ikl, isn), G1_dSV)
+ SaltOK = min(unun, SaltOK + MeltOK) * SnowOK
+ ! +--Mobility Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SaltM1 = -0.750e-2 * G1snSV(ikl, isn) &
+ - 0.500e-2 * G2snSV(ikl, isn) + 0.500e00 !dendritic case
+ ! + CAUTION: Guyomarc'h & Merindol Dendricity Sign is +
+ ! + ^^^^^^^^ MAR Dendricity Sign is -
+ SaltM2 = -0.833d-2 * G1snSV(ikl, isn) &
+ - 0.583d-2 * G2snSV(ikl, isn) + 0.833d00 !non-dendritic case
+ ! SaltMo = (DendOK * SaltM1 + (1.-DendOK) * SaltM2 )
+ SaltMo = 0.625 !SaltMo pour d=s=0.5
+
+ ! weighting SaltMo with surface snow density (Vionnet et al. 2012)
+ ! FacRho = 1.25 - 0.0042 * ro__SV(ikl,isn)
+ ! SaltMo = 0.34 * SaltMo + 0.66 * FacRho !needed for polar snow
+ MIN_Mo = 0.
+ ! SaltMo = max(SaltMo,MIN_Mo)
+ ! SaltMo = SaltOK * SaltMo + (1.-SaltOK) * min(SaltMo,SaltMx)
+#if(TUNE)
+ SaltMo = SaltOK * SaltMo - (1.-SaltOK) * 0.9500
+#endif
+ SaltMo = max(SaltMo, epsi - unun)
+ ! +--Influence of Density on Threshold Shear Stress
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ Por_BS = 1.-300./ro_Ice
+ ! SheaBS = Arg(sqrt(shear = max shear stress in snow)):
+ ! shear = 3.420d00 * exp(-(Por_BS +Por_BS) /(unun -Por_BS))
+ ! SheaBS : see de Montmollin (1978),
+ ! These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124
+ ShearS = Por_BS / (1.-Por_BS)
+
+ ! +--Snow Drift Index (Guyomarc'h & Merindol 1997, Ann.Glaciol.)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ArguSi = -0.085 * us__SV(ikl) / rCd10n
+ !V=u*/sqrt(CD) eqs 2 to 4 Gallee et al. 2001
+ SaltSI(ikl, isn) = -2.868 * exp(ArguSi) + 1 + SaltMo
+ ! +--Threshold Friction Velocity
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ro__SV(ikl, isn) > 300.) then
+ Por_BS = 1.000 - ro__SV(ikl, isn) / ro_Ice
+ else
+ Por_BS = 1.000 - 300./ro_Ice
+ endif
+ ShearX = Por_BS / max(epsi, 1.-Por_BS)
+ ! + Gallee et al., 2001 eq 5, p5
+ Fac_Mo = exp(-ShearX + ShearS)
+ if(usth_param == "gal") then
+ Salt_us = (log(2.868) - log(1 + SaltMo)) * rCd10n / 0.085
+ ! Salt_us : Extension of Guyomarc'h & Merindol 1998 with
+ ! de Montmollin (1978). Gallee et al. 2001
+ Salt_us = Salt_us * Fac_Mo
+ endif
+ if(usth_param == "lis") then !Liston et al. 2007
+ if(ro__SV(ikl, isn) > 300.) then
+ Salt_us = 0.005 * exp(0.013 * ro__SV(ikl, isn))
+ else
+ Salt_us = 0.01 * exp(0.003 * ro__SV(ikl, isn))
+ endif
+ endif
+ SnowOK = 1 - min(1, iabs(isn - isnoSV(ikl))) !Switch new vs old snow
+ usthSV(ikl) = SnowOK * (Salt_us) + (1.-SnowOK) * usthSV(ikl)
+ enddo
+ ! end do
+#endif
+
+ ! Effective SBL variables
+ ! =======================
+
+ do ikl = 1, klonv
+ VVaSBL(ikl) = VV__SV(ikl)
+ VVaSBL(ikl) = VVmmem(ikl)
+ dTa_Ts(ikl) = TaT_SV(ikl) - Tsrfsv(ikl)
+ dTa_Ts(ikl) = dTmmem(ikl)
+ enddo
+
+ ! Convergence Criterion
+ ! =====================
+
+ icount = 0
+
+1 continue
+ icount = icount + 1
+ dustar = 0.
+
+ do ikl = 1, klonv
+
+ u0star = us__SV(ikl)
+
+#if(AM)
+ ! u*, u*T*, u*s* Time Moving Averages
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ u0star = 0.0
+#if(AT)
+ uTstar = 0.0
+#endif
+#if(AS)
+ usstar = 0.0
+#endif
+ do nt = 1, ntaver
+ u0star = u0star + u__mem(ikl, nt)
+#if(AT)
+ uTstar = uTstar + uT_mem(ikl, nt)
+#endif
+#if(AS)
+ usstar = usstar + us_mem(ikl, nt)
+#endif
+ enddo
+ u0star = u0star / ntaver
+ us__SV(ikl) = u0star
+#if(AT)
+ uts_SV(ikl) = uTstar / ntaver
+#endif
+#if(AS)
+ uss_SV(ikl) = usstar / ntaver
+#endif
+#endif
+
+ ! Turbulent Scales from previous Time Step
+ ! ----------------------------------------
+
+ u0star = max(epsi, u0star) ! Friction Velocity u*
+ uustar = u0star * u0star ! Friction Velocity^2 uu*
+ thstar = uts_SV(ikl) / u0star ! Temperature theta*
+ qqstar = uqs_SV(ikl) / u0star ! Specific Humidity qq*
+ ssstar = uss_SV(ikl) / u0star ! Blown Snow ss*
+
+ ! Monin-Obukhov Stability Parameter for Momentum
+ ! ----------------------------------------------
+
+ ! Pseudo Virtual Temperature Turbulent Scale thetav*
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ thstarv = thstar + Theta0 * (0.608 * qqstar) &
+ / (1.+0.608 * QaT_SV(ikl) - qsnoSV(ikl))
+ thstars = sign(unun, thstarv)
+ thstara = abs(thstarv)
+ thstarv = max(epsi, thstara) * thstars
+
+ ! Pseudo Obukhov Length Scale (Gall?e et al., 2001 BLM 99, (A2) p.17)
+ ! Full Obukhov Length Scale (when Blowing * is ##NOT## switched ON)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ LMO_SV(ikl) = Theta0 * max(epsi, uustar) &
+ / (vonkar * gravit * thstarv)
+#if(wr)
+ W_pLMO = LMO_SV(ikl)
+#endif
+
+ zetah = za__SV(ikl) / LMO_SV(ikl)
+ zetam = min(zetMAX, zetah)! Strong Stability Limit
+ ! !(Mahalov et al. 2004
+ ! ! GRL 31 2004GL021055)
+ LMOmom(ikl) = za__SV(ikl) / (max(epsi, abs(zetam)) &
+ * sign(unun, zetam))
+ zeta0m = Z0m_SV(ikl) / LMOmom(ikl)
+ zeta0h = Z0h_SV(ikl) / LMO_SV(ikl)
+
+ ! Momentum Pseudo Stability Function (Gall?e et al. 2001, BLM 99, (11) p. 7)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ stab_s = max(zero, sign(unun, zetam))
+
+ psim_s = -A_Turb * zetam
+ xpsimi = sqrt(sqrt(unun - coef_m * min(zero, zetam)))
+ psim_i = 2.*log(demi * (unun + xpsimi)) &
+ + log(demi * (unun + xpsimi * xpsimi)) &
+ - 2.*atan(xpsimi) + demi * pi
+ psim_z = stab_s * psim_s + (1.-stab_s) * psim_i
+#if(wr)
+ W_psim = psim_z
+#endif
+
+ psim_s = -A_Turb * zeta0m
+ xpsimi = sqrt(sqrt(unun - coef_m * min(zero, zeta0m)))
+ psim_i = 2.*log(demi * (unun + xpsimi)) &
+ + log(demi * (unun + xpsimi * xpsimi)) &
+ - 2.*atan(xpsimi) + demi * pi
+ psim_0 = stab_s * psim_s + (1.-stab_s) * psim_i
+
+#if(AE)
+ ! Virtual Temperature Turbulent Scale thetav* (ss* impact included )
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ needed for new ss*)
+ thstarv = thstar + Theta0 * (0.608 * qqstar &
+ - ssstar &
+ ) &
+ / (1.+0.608 * QaT_SV(ikl) - qsnoSV(ikl))
+ thstars = sign(unun, thstarv)
+ thstara = abs(thstarv)
+ thstarv = max(epsi, thstara) * thstars
+ ! Full Obukhov Length Scale (Gallee et al. 2001, BLM 99, (A1) p.16)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ LMO_SV(ikl) = Theta0 * us__SV(ikl) * us__SV(ikl) &
+ / (vonkar * gravit * thstarv)
+ zetah = za__SV(ikl) / LMO_SV(ikl)
+ ! Strong Stability Limit (Mahalov et al. 2004 GRL 31 2004GL021055)
+ zetam = min(zetMAX, zetah)
+ LMOmom(ikl) = za__SV(ikl) / (max(epsi, abs(zetam)) &
+ * sign(unun, zetam))
+ zeta0m = Z0m_SV(ikl) / LMOmom(ikl)
+ ! Snow Erosion Stability Function (Gall?e et al. 2001, BLM 99, (11) p. 7)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ stab_s = max(zero, sign(unun, zetam))
+ psis_s = -AsTurb * zetam
+ xpsimi = sqrt(sqrt(unun - coef_m * min(zero, zetam)))
+ psim_i = 2.*log(demi * (unun + xpsimi)) &
+ + log(demi * (unun + xpsimi * xpsimi)) &
+ - 2.*atan(xpsimi) + demi * pi
+ psis_z = stab_s * psis_s + (1.-stab_s) * psim_i
+ psis_s = -AsTurb * zeta0m
+ xpsimi = sqrt(sqrt(unun - coef_m * min(zero, zeta0m)))
+ psim_i = 2.*log(demi * (unun + xpsimi)) &
+ + log(demi * (unun + xpsimi * xpsimi)) &
+ - 2.*atan(xpsimi) + demi * pi
+ psis_0 = stab_s * psis_s + (1.-stab_s) * psim_i
+ ! Square Roots of the Drag Coefficient for Snow Erosion Turbulent Flux
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ rCDmSV(ikl) = vonkar / (sqrCm0(ikl) - psim_z + psim_0)
+#endif
+
+#if(ss)
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6600) Z0m_SV(ikl), psim_z &
+ , LMO_SV(ikl), uustar &
+ , sqrCm0(ikl), psim_0 &
+ , LMOmom(ikl), thstarv
+6600 format(/, ' ** SISVATeSBL *0 ' &
+ , ' Z0m_SV = ', e12.4, ' psim_z = ', e12.4 &
+ , ' LMO_SV = ', e12.4, ' uustar = ', e12.4 &
+ , /, ' ' &
+ , ' sqrCm0 = ', e12.4, ' psim_0 = ', e12.4 &
+ , ' LMOmom = ', e12.4, ' thstarv = ', e12.4)
+#endif
+
+ ! Momentum Turbulent Scale u*
+ ! ---------------------------------------
+
+ ! Momentum Turbulent Scale u* in case of NO Blow. Snow
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ VVa_OK = max(0.000001, VVaSBL(ikl))
+ sss__N = vonkar * VVa_OK
+ sss__F = (sqrCm0(ikl) - psim_z + psim_0)
+ usuth0 = sss__N / sss__F ! u* if NO Blow. Snow
+
+#if(AE)
+ ! Momentum Turbulent Scale u* in case of Blow. Snow
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ sss__G = 0.27417 * gravit
+ ! ______________ _____
+ ! Newton-Raphson (! Iteration, BEGIN)
+ ! ~~~~~~~~~~~~~~ ~~~~~
+ do iit = 1, nit
+ sss__K = gravit * r_Turb * A_Turb * za__SV(ikl) &
+ * rCDmSV(ikl) * rCDmSV(ikl) &
+ / (1.+0.608 * QaT_SV(ikl) - qsnoSV(ikl))
+ us_127 = exp(SblPom * log(us__SV(ikl)))
+ us_227 = us_127 * us__SV(ikl)
+ us_327 = us_227 * us__SV(ikl)
+ us_427 = us_327 * us__SV(ikl)
+ us_527 = us_427 * us__SV(ikl)
+ us__SV(ikl) = us__SV(ikl) &
+ - (us_527 * sss__F / sss__N &
+ - us_427 &
+ - us_227 * qsnoSV(ikl) * sss__K &
+ + (us__SV(ikl) * us__SV(ikl) - usthSV(ikl) * usthSV(ikl)) / sss__G) &
+ / (us_427 * 5.27 * sss__F / sss__N &
+ - us_327 * 4.27 &
+ - us_127 * 2.27 * qsnoSV(ikl) * sss__K &
+ + us__SV(ikl) * 2.0 / sss__G)
+ us__SV(ikl) = min(us__SV(ikl), usuth0)
+ us__SV(ikl) = max(us__SV(ikl), epsi)
+ rCDmSV(ikl) = us__SV(ikl) / VVa_OK
+ sss__F = vonkar / rCDmSV(ikl)
+ enddo
+ us__SV(ikl) = usuth0 !desactivate feedback between BS and u*
+ ! ______________ ___
+ ! Newton-Raphson (! Iteration, END )
+ ! ~~~~~~~~~~~~~~ ~~~
+ us_127 = exp(SblPom * log(us__SV(ikl)))
+ us_227 = us_127 * us__SV(ikl)
+ ! Momentum Turbulent Scale u*: 0-Limit in case of no Blow. Snow
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dusuth = us__SV(ikl) - usthSV(ikl)
+ signus = max(sign(unun, dusuth), zero)
+#endif
+ us__SV(ikl) = usuth0
+#if(AE)
+ us__SV(ikl) = us__SV(ikl) * (1.-signus)
+ ! Blowing Snow Turbulent Scale ss*
+ ! ---------------------------------------
+ hSalSV(ikl) = 8.436e-2 * us__SV(ikl)**SblPom
+ if(qsalt_param == "pom") then
+ qSalSV(ikl) = (us__SV(ikl)**2 - usthSV(ikl)**2) * signus &
+ / (hSalSV(ikl) * gravit * us__SV(ikl) * 4.2)
+ endif
+ if(qsalt_param == "bin") then
+ qSalSV(ikl) = (us__SV(ikl) * us__SV(ikl) &
+ - usthSV(ikl) * usthSV(ikl)) * signus &
+ * 0.535 / (hSalSV(ikl) * gravit)
+ endif
+ ssstar = rCDmSV(ikl) * (qsnoSV(ikl) - qSalSV(ikl)) &
+ * r_Turb !Bintanja 2000, BLM
+ ! r_Turb compensates for an overestim. of the blown snow part. fall velocity
+ uss_SV(ikl) = min(zero, us__SV(ikl) * ssstar)
+#endif
+#if(BS)
+ uss_SV(ikl) = max(-0.0001, uss_SV(ikl))
+#endif
+
+#if(ss)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ii__SV(ikl) == iwr_SV .and. jj__SV(ikl) == jwr_SV .and. &
+ nn__SV(ikl) == nwr_SV) &
+ write(6, 6610) usuth0, us__SV(ikl) &
+ , qsnoSV(ikl), uss_SV(ikl) &
+ , usthSV(ikl), LMO_SV(ikl) &
+ , qSalSV(ikl), VVa_OK
+6610 format(/, ' ** SISVATeSBL *1 ' &
+ , ' u*(nBS) = ', e12.4, ' u*(_BS) = ', e12.4 &
+ , ' Qs = ', e12.4, ' u*Qs* = ', e12.4 &
+ , /, ' ' &
+ , ' u*(_th) = ', e12.4, ' LMO = ', e12.4 &
+ , ' QSalt = ', e12.4, ' VVa = ', e12.4)
+#endif
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ikl == kSV_v1 .and. lSV_v1 > 0 &
+ .and. lSV_v1 <= 2) &
+ write(6, 6000) daHost, icount, &
+ us__SV(ikl), 1.e3 * hSalSV(ikl), &
+ 1.e3 * Z0m_SV(ikl), &
+ 1.e3 * qsnoSV(ikl), 1.e3 * qSalSV(ikl) &
+ , usthSV(ikl), us__SV(ikl) - usthSV(ikl), &
+ 1.e3 * ssstar, 1.e3 * us__SV(ikl) * ssstar
+6000 format(a18, i3, 6x, 'u* [m/s] =', f6.3, ' hSalt[mm]=', e9.3, &
+ ' Z0m [mm] =', f9.3, ' q [g/kg] =', f9.3, &
+ /, 91x, ' qSa [g/kg] =', f9.3, &
+ /, 27x, 'ut*[m/s]=', e9.3, ' u*-ut* =', e9.3, &
+ ' s* [g/kg] =', f9.3, ' us* [mm/s] =', f9.3)
+#endif
+
+#if(AE)
+ ! Virtual Temperature Turbulent Scale thetav* (ss* impact included)
+ ! --------------------------------------------------------------------
+ thstarv = thstar + Theta0 * (0.608 * qqstar &
+ - ssstar &
+ ) &
+ / (1.+0.608 * QaT_SV(ikl) - qsnoSV(ikl))
+ thstars = sign(unun, thstarv)
+ thstara = abs(thstarv)
+ thstarv = max(epsi, thstara) * thstars
+ ! Full Obukhov Length Scale (Gall?e et al., 2001, BLM 99, (A1) p.16)
+ ! --------------------------------------------------------------------
+ LMO_SV(ikl) = Theta0 * us__SV(ikl) * us__SV(ikl) &
+ / (vonkar * gravit * thstarv)
+ zetah = za__SV(ikl) / LMO_SV(ikl)
+ ! Strong Stability Limit (Mahalov et al. 2004 GRL 31 2004GL021055)
+ zetam = min(zetMAX, zetah)
+ LMOmom(ikl) = za__SV(ikl) / (max(epsi, abs(zetam)) &
+ * sign(unun, zetam))
+ zeta0m = Z0m_SV(ikl) / LMOmom(ikl)
+ zeta0h = Z0h_SV(ikl) / LMO_SV(ikl)
+#endif
+
+#if(wx)
+ ! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(ikl == kSV_v1 .and. lSV_v1 > 0 &
+ .and. lSV_v1 <= 2) &
+ write(6, 6001) LMO_SV(ikl), zetah
+#endif
+6001 format(18x, 9x, 'LMO [m]=', f9.1, ' zetah[-] =', f9.3)
+
+ ! Turbulent Scales
+ ! ----------------
+
+ ! Momentum Stability Function (Gall?e et al., 2001, BLM 99, (11) p. 7)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ stab_s = max(zero, sign(unun, zetam))
+
+ psim_s = -A_Turb * zetam
+ xpsimi = sqrt(sqrt(unun - coef_m * min(zero, zetam)))
+ psim_i = 2.*log(demi * (unun + xpsimi)) &
+ + log(demi * (unun + xpsimi * xpsimi)) &
+ - 2.*atan(xpsimi) + demi * pi
+ psim_z = stab_s * psim_s + (1.-stab_s) * psim_i
+
+ psim_s = -A_Turb * zeta0m
+ xpsimi = sqrt(sqrt(unun - coef_m * min(zero, zeta0m)))
+ psim_i = 2.*log(demi * (unun + xpsimi)) &
+ + log(demi * (unun + xpsimi * xpsimi)) &
+ - 2.*atan(xpsimi) + demi * pi
+ psim_0 = stab_s * psim_s + (1.-stab_s) * psim_i
+
+ ! Heat Stability Function (Gall?e et al., 2001, BLM 99, (11) p. 7)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ stab_s = max(zero, sign(unun, zetah))
+
+ psih_s = -AhTurb * zetah
+ xpsihi = sqrt(sqrt(unun - coef_h * min(zero, zetah)))
+ psih_i = 2.*log(demi * (unun + xpsihi))
+ psih_z = stab_s * psih_s + (1.-stab_s) * psih_i
+
+ psih_s = -AhTurb * zeta0h
+ xpsihi = sqrt(sqrt(unun - coef_h * min(zero, zeta0h)))
+ psih_i = 2.*log(demi * (unun + xpsihi))
+ psih_0 = stab_s * psih_s + (1.-stab_s) * psih_i
+
+ ! Square Roots of the Drag Coefficients
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ rCDhSV(ikl) = vonkar * (ExnrSV(ikl) / pcap) &
+ / (sqrCh0(ikl) - psih_z + psih_0)
+ rCDmSV(ikl) = vonkar / (sqrCm0(ikl) - psim_z + psim_0)
+
+ ! Drag Coefficients
+ ! ~~~~~~~~~~~~~~~~~
+ CDh(ikl) = rCDmSV(ikl) * rCDhSV(ikl)
+ CDm(ikl) = rCDmSV(ikl) * rCDmSV(ikl)
+
+ ! real Temperature Turbulent Scale theta*
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ thstar = rCDhSV(ikl) * dTa_Ts(ikl) &
+ * (pcap / ExnrSV(ikl))
+ uts_SV(ikl) = us__SV(ikl) * thstar
+
+ ! Convergence Criterion
+ ! =====================
+
+ dustar = max(dustar, abs(us__SV(ikl) - u0star))
+
+#if(AM)
+ ! u*, u*T*, u*s* Time Moving Averages
+ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ do nt = 1, ntaver - 1
+ u__mem(ikl, nt) = u__mem(ikl, nt + 1)
+#if(AT)
+ uT_mem(ikl, nt) = uT_mem(ikl, nt + 1)
+#endif
+#if(AS)
+ us_mem(ikl, nt) = us_mem(ikl, nt + 1)
+#endif
+ enddo
+ u__mem(ikl, ntaver) = us__SV(ikl)
+#if(AT)
+ uT_mem(ikl, ntaver) = uts_SV(ikl)
+#endif
+#if(AS)
+ us_mem(ikl, ntaver) = uss_SV(ikl)
+#endif
+#endif
+
+#if(wr)
+ ! OUTPUT for Verification (general)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~
+ if(icount == 1) then
+ write(6, 6004)
+6004 format(122('-'))
+ if(mod(VVaSBL(ikl), 4.) < 0.1) then
+ write(6, 6003)
+6003 format(' V Ta-Ts Z0 It' &
+ , ' du* u* sss__F CD Qss Qs* ' &
+ , ' PseudOL Full-OL zetam zetah psim_z psih_z')
+ write(6, 6004)
+ endif
+ endif
+ write(6, 6002) VVaSBL(ikl), dTa_Ts(ikl), Z0m_SV(ikl), icount &
+ , dustar, us__SV(ikl), sss__F &
+ , CDm(ikl), qSalSV(ikl), ssstar &
+ , W_pLMO, LMO_SV(ikl) &
+ , zetam, zetah, W_psim, psih_z
+6002 format(2f6.1, f8.4, i3, f9.6, f6.3, f9.3, 3f9.6, 2f8.2, 2f8.4, 2f8.2)
+#endif
+
+#if(w1)
+ ! OUTPUT for Verification (u*_AE)
+ ! ~~~~~~~~~~~~~~~~~~~~~~~
+ if(icount == 1) then
+ write(6, 6014)
+6014 format(100('-'))
+ if(mod(VVaSBL(ikl), 4.) < 0.1) then
+ write(6, 6013)
+6013 format(' V Ta-Ts Z0 It' &
+ , ' du* u* sss__F W_NUs1 W_NUs2 W_NUs3 ' &
+ , ' W_DUs1 W_DUs2 ')
+ write(6, 6014)
+ endif
+ endif
+ write(6, 6012) VVaSBL(ikl), dTa_Ts(ikl), Z0m_SV(ikl), icount &
+ , dustar, us__SV(ikl), sss__F &
+ , W_NUs1, W_NUs2, W_NUs3 &
+ , W_DUs1, W_DUs2
+6012 format(2f6.1, f8.4, i3, f9.6, f6.3, f9.3, 3f9.3, 2f12.3)
+#endif
+
+ enddo
+
+#if(IX)
+ if(icount < 3) go to 1
+#endif
+ ! if (dustar.gt.0.0001.and.icount.lt. 6) go to 1
+
+#if(AM)
+ do ikl = 1, klonv
+ u0star = 0.0
+#if(AT)
+ uTstar = 0.0
+#endif
+#if(AS)
+ usstar = 0.0
+#endif
+ do nt = 1, ntaver
+ u0star = u0star + u__mem(ikl, nt)
+#if(AT)
+ uTstar = uTstar + uT_mem(ikl, nt)
+#endif
+#if(AS)
+ usstar = usstar + us_mem(ikl, nt)
+#endif
+ enddo
+ us__SV(ikl) = u0star / ntaver
+#if(AT)
+ uts_SV(ikl) = uTstar / ntaver
+#endif
+#if(AS)
+ uss_SV(ikl) = usstar / ntaver
+#endif
+ enddo
+#endif
+
+ ! Aerodynamic Resistances
+ ! -----------------------
+
+ do ikl = 1, klonv
+ ram_sv(ikl) = 1./(CDm(ikl) * max(VVaSBL(ikl), epsi))
+ rah_sv(ikl) = 1./(CDh(ikl) * max(VVaSBL(ikl), epsi))
+ enddo
+
+ return
+endsubroutine SISVATeSBL
diff --git a/MAR/code_mar/sspray.f90 b/MAR/code_mar/sspray.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a18607be71ec43c5144837d4c8a6a8b511932466
--- /dev/null
+++ b/MAR/code_mar/sspray.f90
@@ -0,0 +1,163 @@
+#include "MAR_pp.def"
+subroutine sspray
+ ! +--------------------------------------------------------------------------+
+ ! | Sat 29-Jul-2009 |
+ ! | |
+ ! | subroutine sspray computes contribution of Sea Spray |
+ ! | ^^^^^^ to Sensible & Latent Heat Flux |
+ ! | |
+ ! | Reference A_03 Andreas, 2003, Preprints. |
+ ! | 12th Conference on Interactions of the Sea & Atmosphere |
+ ! | Long Beach, CA, American Meteorological Society |
+ ! | http://ams.confex.com/ams/pdfpapers/77949.pdf |
+ ! | |
+ ! | AD02 Andreas & Decosmo, 2002, BLM 103, 303-333 |
+ ! | The signature of sea spray |
+ ! | in the HEXOS turbulent heat flux data |
+ ! | |
+ ! | AE01 Andreas & Emanuel, 2001, JAS 58, 3741-3751 |
+ ! | Effects of Sea Spray on Tropical Cyclone Intensity |
+ ! | |
+ ! | A_95 Andreas, 1995, JAS 52(7) , 852-862 |
+ ! | The Temperature of Evaporating Sea Spray Droplets |
+ ! | |
+ ! | A_90 Andreas, 1990, Tellus 42B, 481-497 |
+ ! | Time Constants for the Evolution of Sea Spray Droplets |
+ ! | |
+ ! | |
+ ! +--------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_sl
+ use mar_wk
+#if(iso)
+ use mariso, only: wiso, niso, qvDY_iso, qiHY_iso
+#endif
+
+ implicit none
+
+ ! +--Internal Constants and Variables
+ ! + =================================
+ ! alphaC : A_03 (3)
+ real, parameter :: alphaC = 0.0185
+ ! Uf_Spr = .1 = 1/tau_f where tau_f = 10 sec (A_90 fig9)
+ real, parameter :: Uf_Spr = 0.1
+ ! t50_eq : (A_90 fig9)
+ real, parameter :: t50_eq = 0.2000e+3
+ ! f50_eq : 0.3125e-4 = 50.e-6 m * 0.5 / 0.8 ; * 0.5 when RH = 0.8 (A_90, p490)
+ real, parameter :: f50_eq = 0.3125e-4
+ integer i, j, k, m
+ real ustar2, alo10g, A13wav, tf_Spr
+ real Ta_wet, r50_eq, r50__t, r50n_t, QS_Spr, qq_Spr, QL_Spr
+ real :: qq_spr_mass
+#if(iso)
+ real :: qq_spr_iso(niso)
+ ! rh : diagnostic
+ real :: rh, fac, fac1, fac2, fac3
+#endif
+
+ ! +--Wave Height
+ ! + ===========
+
+ do j = 1, my
+ do i = 1, mx
+ ! AD02 ( 4)
+ A13wav = 0.015 * ssvSL(i, j, mz)
+#if(A3)
+ ustar2 = SLuusl(i, j, 1) * SLuusl(i, j, 1)
+ alo10g = log(10.*gravit / alphaC)
+ ! A_03 (13)
+ A13wav = 0.015 * (ustar2 / vonkar) * (2.*ustar2 - SLuusl(i, j, 1) * (2.*alo10g + 8.)) &
+ + (alo10g * alo10g + 2.*alo10g + 4.)
+#endif
+ A13wav = min(20., A13wav)
+
+ ! +--Sea Spray Residence Time
+ ! + ========================
+ ! A_03 (12)
+ tf_Spr = A13wav / Uf_Spr
+
+ ! +--Sea Spray Sensible Heat Flux Correction
+ ! + =======================================
+ ! A_95
+ Ta_wet = tairDY(i, j, mz) - (Lv_H2O / cp) * (qvswDY(i, j, mz) - qvDY(i, j, mz))
+ Ta_wet = max(tfrwat, Ta_wet)
+ ! AE01 ( 7)
+ QS_Spr = 4.187e6 * (tsrfSL(i, j, 1) - Ta_wet) &
+ ! A_03 (14a)
+ * 1.65e-6 * SLuusl(i, j, 1) * SLuusl(i, j, 1) * SLuusl(i, j, 1)
+
+ ! +--Sea Spray Latent Heat Flux Correction
+ ! + =====================================
+
+ ! A_90 p490
+ r50_eq = f50_eq * min(1., qvDY(i, j, mz) / qvswDY(i, j, mz))
+ r50__t = r50_eq + (50.e-6 - r50_eq) * exp(-tf_Spr / t50_eq)
+ r50n_t = r50__t / 50.e-6
+ ! A_03 (11)
+ qq_Spr = 1000.00 * (1.-r50n_t * r50n_t * r50n_t) * 2.65e-8 * SLuusl(i, j, 1)**2.61
+ ! A_03 (11)
+ QL_Spr = -Lv_H2O * qq_Spr
+
+ ! +--Update
+ ! + ======
+#if(X)
+ ! +--Increment
+ ! + ~~~~~~~~~
+ pktaDY(i, j, mz) = pktaDY(i, j, mz) + maskSL(i, j) * SLsrfl(i, j, 1) &
+ * (QS_Spr + QL_Spr) * dt_Loc / (1.e3 * pstDYn(i, j) * dsigm1(mz) * grvinv) &
+ / (pkDY(i, j, mz) * cp)
+#endif
+ WKxy1(i, j) = maskSL(i, j) * SLsrfl(i, j, 1) &
+ * (QS_Spr + QL_Spr) * dt_Loc / (1.e3 * pstDYn(i, j) * dsigm1(mz) * grvinv) &
+ / (pkDY(i, j, mz) * cp) !
+
+ ! +--Increment (after limiting the fluxes)
+ ! + ~~~~~~~~~
+ WKxy2(i, j) = &
+ ! LOWER
+ max(0.0, sign(1., pktaDY(i, j, mz) - pktaDY(i, j, mzz))) &
+ * max(0.0, sign(1., pktaDY(i, j, mzz) - pktaDY(i, j, mz) - WKxy1(i, j))) &
+ * max(WKxy1(i, j), pktaDY(i, j, mzz) - pktaDY(i, j, mz)) &
+ ! UPPER
+ + max(0.0, sign(1., pktaDY(i, j, mz) - pktaDY(i, j, mzz) + WKxy1(i, j))) &
+ * max(0.0, sign(1., pktaDY(i, j, mzz) - pktaDY(i, j, mz))) &
+ * min(WKxy1(i, j), pktaDY(i, j, mzz) - pktaDY(i, j, mz)) &
+ ! OTHER
+ + max(0.0, sign(1., pktaDY(i, j, mz) - pktaDY(i, j, mzz) + WKxy1(i, j)) &
+ * sign(1., pktaDY(i, j, mz) - pktaDY(i, j, mzz))) &
+ * WKxy1(i, j)
+
+ ! max: 10°C/h
+ WKxy2(i, j) = sign(1., WKxy2(i, j)) * min(10.*dt / 3600., abs(WKxy2(i, j)))
+ pktaDY(i, j, mz) = pktaDY(i, j, mz) + WKxy2(i, j)
+
+ qq_Spr = qq_Spr * WKxy2(i, j) / (sign(1.0, WKxy1(i, j)) * max(eps9, abs(WKxy1(i, j))))
+ qq_spr_mass = maskSL(i, j) * SLsrfl(i, j, 1) * qq_Spr * dt_Loc / (1.e3 * pstDYn(i, j) * dsigm1(mz) * grvinv)
+
+#if(iso)
+ ! todo : check if vectorized by the compiler, check performance
+ call iso_surf_ocean(pstDYn(i, j), tsrfSL(i, j, 1), qvDY(i, j, mz), ssvSL(i, j, mz), qvDY_iso(:, i, j, mz), &
+ qq_spr_mass, qq_spr_iso)
+ do wiso = 1, niso
+ qvDY_iso(wiso, i, j, mz) = qvDY_iso(wiso, i, j, mz) + qq_spr_iso(wiso)
+ enddo
+ ! **reminder**, water update (here qvDY) must be **after** isotope factionation computation
+#endif
+ qvDY(i, j, mz) = qvDY(i, j, mz) + qq_spr_mass
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ enddo
+ enddo
+
+ return
+end
diff --git a/MAR/code_mar/stereosouth.f90 b/MAR/code_mar/stereosouth.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f97ee414f809d709668e3bb5d1b618d378fd4e02
--- /dev/null
+++ b/MAR/code_mar/stereosouth.f90
@@ -0,0 +1,229 @@
+subroutine StereoSouth(E, N, GEddxx, lon, lat, GElat0)
+ ! +----------------------------------------------------------------------+
+ ! | Compute the lon, lat from Polar Stereographic Projection |
+ ! | Written by Cecile Agosta 23-12-21 |
+ ! | EPSG Polar Stereographic transformation Variant B |
+ ! | (http://www.epsg.org/guides/docs/G7-2.pdf) |
+ ! | Equivalent to EPSG 3031 (WGS-84 ellipsoid) for SH |
+ ! | Equivalent to EPSG 3413 (WGS-84 ellipsoid) for NH |
+ ! +----------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : E : Stereo coordinate on the East (X, km) |
+ ! | ^^^^^^^ N : Stereo coordinate on the North (Y, km) |
+ ! | GEddxx : Longitude of X axis (=GEddxx, 90 = East, clockwise)|
+ ! | [lat true = 71] |
+ ! | |
+ ! | OUTPUT : lon : longitude (deg) |
+ ! | ^^^^^^^ lat : latitude (deg) |
+ ! | |
+ ! +----------------------------------------------------------------------+
+
+ use mardim
+
+ implicit none
+
+ ! +-- General Variables
+ ! + -----------------
+ real, INTENT(in) :: E, N, GEddxx
+ real, INTENT(out) :: lon, lat
+
+ ! +-- Local Variables
+ ! + ---------------
+ real ddista
+
+ ! +-- Constants
+ ! + ---------
+ real aa, ex, pi, degrad, latF, FE, FN, tF, mF, k0, t, rho, khi, lon0
+ real trulat, GElat0
+
+ ! aa : aa (km) = demi grand axe
+ aa = 6378.1370
+ ! ex : excentricity WGS-84 : 0.081 819 190 842 622 0.081 819 190 842 621
+ ex = 0.081819190842621
+
+ if(sign(1., GElat0) <= 0) then
+ ! trulat : Latitude of standard parallel, 71S for ESPG 3031
+ trulat = -71.
+ else
+ ! trulat : Latitude of standard parallel, 70N for EPSG 3413
+ trulat = 70.
+ endif
+
+ pi = 4.*atan(1.)
+ degrad = pi / 180.
+
+ latF = trulat * degrad
+ lon0 = (GEddxx - 90.) * degrad
+
+ ! FE : False Easting
+ FE = 0.
+ ! FN : False Northing
+ FN = 0.
+
+ ! +- Polar Stereographic Projection
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(sign(1., GElat0) <= 0) then
+ tF = tan(pi / 4 + latF / 2) / &
+ ((1 + ex * sin(latF)) / (1 - ex * sin(latF)))**(ex / 2)
+ else
+ tF = tan(pi / 4 - latF / 2) * &
+ ((1 + ex * sin(latF)) / (1 - ex * sin(latF)))**(ex / 2)
+ endif
+
+ mF = cos(latF) / (1 - ex**2 * sin(latF)**2)**0.5
+ k0 = mF * ((1 + ex)**(1 + ex) * (1 - ex)**(1 - ex))**0.5 / (2 * tF)
+
+ rho = ((E - FE)**2 + (N - FN)**2)**0.5
+ t = rho * ((1 + ex)**(1 + ex) * (1 - ex)**(1 - ex))**0.5 / (2 * aa * k0)
+
+ if(sign(1., GElat0) <= 0) then
+ khi = 2 * atan(t) - pi / 2
+ else
+ khi = pi / 2 - 2 * atan(t)
+ endif
+
+ lat = khi &
+ + (ex**2 / 2 + 5 * ex**4 / 24 + ex**6 / 12 + 13 * ex**8 / 360) &
+ * sin(2 * khi) &
+ + (7 * ex**4 / 48 + 29 * ex**6 / 240 + 811 * ex**8 / 11520) &
+ * sin(4 * khi) &
+ + (7 * ex**6 / 120 + 81 * ex**8 / 1120) &
+ * sin(6 * khi) &
+ + (4279 * ex**8 / 161280) &
+ * sin(8 * khi)
+
+ if(E - FE == 0. .and. N - FN == 0) then
+ lon = lon0 + pi / 2.
+ else if(E - FE == 0. .and. N - FN >= 0) then
+ if(sign(1., GElat0) <= 0) then
+ lon = lon0
+ else
+ lon = lon0 - pi
+ endif
+ else if(E - FE == 0. .and. N - FN <= 0) then
+ if(sign(1., GElat0) <= 0) then
+ lon = lon0 - pi
+ else
+ lon = lon0
+ endif
+ else
+
+ if(sign(1., GElat0) <= 0) then
+ lon = lon0 + atan2(E - FE, N - FN)
+ else
+ lon = lon0 + atan2(E - FE, FN - N)
+ endif
+
+ endif
+
+ lat = lat / degrad
+ lon = lon / degrad
+ if(lon > 180.) then
+ lon = lon - 360.
+ else if(lon < -180.) then
+ lon = lon + 360.
+ endif
+
+ return
+endsubroutine StereoSouth
+
+subroutine StereoSouth_inverse(lon, lat, lonE, E, N)
+ ! +----------------------------------------------------------------------+
+ ! | Compute Polar Stereographic Projection from lon,lat coordinates |
+ ! | Written by Cecile Agosta 02-02-21 |
+ ! | EPSG Polar Stereographic transformation Variant B |
+ ! | (http://www.epsg.org/guides/docs/G7-2.pdf) |
+ ! | Equivalent to EPSG 3031 (WGS-84 ellipsoid) for SH |
+ ! | Equivalent to EPSG 3413 (WGS-84 ellipsoid) for NH |
+ ! +----------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : lon : Longitude (deg) |
+ ! | ^^^^^^^ lat : Latitude (deg) |
+ ! | lon0 : Longitude of X axis (90 = East, clockwise) |
+ ! | [lat true = 71 S/71N] |
+ ! | |
+ ! | OUTPUT : E : Stereo coordinate on the East (X, km) |
+ ! | ^^^^^^^^ N : Stereo coordinate on the North (Y, km) |
+ ! | |
+ ! +----------------------------------------------------------------------+
+
+ use mardim
+
+ implicit none
+
+ ! +-- General Variables
+ ! + -----------------
+ real, intent(in) :: lon, lat, lonE
+ real, intent(out) :: E, N
+
+ ! +-- Local Variables
+ ! + ---------------
+ real costru, ddista
+
+ ! +-- Constants
+ ! + ---------
+ real aa, ex, pi, degrad, latF, FE, FN, tF, mF, k0, t, rho, lonrad, latrad
+ real lon0, trulat, GElat0
+
+ GElat0 = lat
+ ! aa : aa (km) = demi grand axe
+ aa = 6378.1370
+ ! ex : excentricity WGS-84 : 0.081 819 190 842 622 0.081 819 190 842 621
+ ex = 0.081819190842621
+
+ if(sign(1., GElat0) <= 0) then
+ ! trulat : Latitude of standard parallel, 71S for ESPG 3031
+ trulat = -71.
+ else
+ ! trulat : Latitude of standard parallel, 70N for EPSG 3413
+ trulat = 70.
+ endif
+
+ pi = 4.*atan(1.)
+ degrad = pi / 180.
+
+ latF = trulat * degrad
+ lon0 = (lonE - 90.) * degrad
+ lonrad = lon * degrad
+ latrad = lat * degrad
+
+ ! FE : False Easting
+ FE = 0.
+ ! FN : False Northing
+ FN = 0.
+
+ ! +
+ ! +- Polar Stereographic Projection
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ! +
+ if(sign(1., GElat0) <= 0) then
+ tF = tan(pi / 4 + latF / 2) / &
+ ((1 + ex * sin(latF)) / (1 - ex * sin(latF)))**(ex / 2)
+ else
+ tF = tan(pi / 4 - latF / 2) * &
+ ((1 + ex * sin(latF)) / (1 - ex * sin(latF)))**(ex / 2)
+ endif
+
+ mF = cos(latF) / (1 - ex**2 * sin(latF)**2)**0.5
+ k0 = mF * ((1 + ex)**(1 + ex) * (1 - ex)**(1 - ex))**0.5 / (2 * tF)
+
+ if(sign(1., GElat0) <= 0) then
+ t = tan(pi / 4 + latrad / 2) / &
+ ((1 + ex * sin(latrad)) / (1 - ex * sin(latrad)))**(ex / 2)
+ else
+ t = tan(pi / 4 - latrad / 2) * &
+ ((1 + ex * sin(latrad)) / (1 - ex * sin(latrad)))**(ex / 2)
+ endif
+
+ rho = 2 * aa * k0 * t / ((1 + ex)**(1 + ex) * (1 - ex)**(1 - ex))**0.5
+
+ E = FE + rho * sin(lonrad - lon0)
+
+ if(sign(1., GElat0) <= 0) then
+ N = FN + rho * cos(lonrad - lon0)
+ else
+ N = FN - rho * cos(lonrad - lon0)
+ endif
+
+ return
+endsubroutine StereoSouth_inverse
diff --git a/MAR/code_mar/svasav.f90 b/MAR/code_mar/svasav.f90
new file mode 100644
index 0000000000000000000000000000000000000000..12ef75d577191b37e1edab072b22da284ab3ecbe
--- /dev/null
+++ b/MAR/code_mar/svasav.f90
@@ -0,0 +1,620 @@
+#include "MAR_pp.def"
+subroutine svasav(ordr)
+ ! +------------------------------------------------------------------------+
+ ! | MAR OUTPUT 12-07-2019 MAR |
+ ! | subroutine svasav is used to save the main SVAT Variables |
+ ! | |
+ ! | # OPTIONS: #OA: Ocean Albedo is prescribed |
+ ! | # ^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_lb
+ use mar_sl
+ use mar_sv
+ use mar_tv
+ use mar_vb
+ use marssn
+ use mardsv
+ use mar_bs
+ use mar_ib
+#if(iso)
+ use mariso, only: iso_init_type, rosSNo_iso, wasSNo_iso, SWaSNo_iso, &
+ snohSN_iso, eta_TV_iso, wiso, niso
+#endif
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+ character(len=4) ordr
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ character(len=6) vartyp
+ integer n1, n2, iteSVA, iyrSVA, mmaSVA, jdaSVA, jhuSVA, n
+ integer i50, j50, iim, jjm, msc
+ integer(kind=8) itexpe2
+ logical :: iniWRI
+ data iniWRI/.true./
+ real mskSNo2(mx, my)
+ real wes_IB(mx, my, mw), weetIB(mx, my, mw)
+
+ ! +--READ
+ ! + ====
+ if(ordr == 'read') then
+404 continue ! problem of itexpe
+ ! +--Open File
+ ! + ---------
+ open(unit=11, status='old', form='unformatted', file='MARsvt.DAT')
+ ! +--Read DATA
+ ! + ---------
+ read(11) iteSVA
+ read(11) iyrSVA, mmaSVA, jdaSVA, jhuSVA
+ if(itexpe == 0) then
+ if(iteSVA /= itexpe .or. &
+ iyrSVA /= iyr0GE .or. &
+ mmaSVA /= mma0GE .or. &
+ jdaSVA /= jda0GE .or. &
+ jhuSVA /= jhu0GE) then
+ write(6, 600) itexpe, iyrSVA, mmaSVA, jdaSVA, jhuSVA, &
+ iyr0GE, mma0GE, jda0GE, jhu0GE
+600 format(' ++ERROR++ MARsvt improperly specified ', &
+ /, ' iyr mma jda jhu', &
+ /, i6, 4i7, ' Old', /, 6x, 4i7, ' Current')
+ endif
+ else
+ if(iteSVA /= itexpe .or. &
+ iyrSVA /= iyrrGE .or. &
+ mmaSVA /= mmarGE .or. &
+ jdaSVA /= jdarGE .or. &
+ jhuSVA /= jhurGE) then
+ write(6, 600) itexpe, iyrSVA, mmaSVA, jdaSVA, jhuSVA, iyrrGE, mmarGE, jdarGE, jhurGE
+ endif
+ if(mmaSVA /= mmarGE .or. jdaSVA /= jdarGE .or. jhuSVA /= jhurGE) then
+ write(6, *)
+ write(6, 400) jdarGE, mmarGE, iyrrGE, jhurGE
+400 format(' MARrun time : ', i2, '/', i2, '/', i4, ' ', i2, ':00')
+ write(6, 401) jdaSVA, mmaSVA, iyrSVA, jhuSVA
+401 format(' MARsim time : ', i2, '/', i2, '/', i4, ' ', i2, ':00')
+ write(6, *)
+ itexpe2 = itexpe
+ do n = -300, 300, 1
+ itexpe = real(itexpe2) / dt * (dt + n)
+ call timgeo()
+ if(iyrrGE == iyrSVA .and. mmarGE == mmaSVA .and. &
+ jdaSVA == jdarGE .and. jhuSVA == jhurGE) then
+ write(6, 402) nint(dt + n)
+402 format(' Previous time step:', i4)
+ write(6, 403) nint(dt)
+403 format(' Current time step:', i4)
+ write(6, *) "Reinitialization of itexpe..."
+ write(6, *)
+ close(11)
+ goto 404
+ endif
+ enddo
+ stop
+ endif
+ endif
+ ! IOi_TV : IO i Index
+ read(11) IOi_TV
+ ! IOj_TV : IO j Index
+ read(11) IOj_TV
+ ! isolTV : Soil Type Index
+ read(11) isolTV
+ ! iWaFTV : =0 ==> no Water Flux =1 ==> free Drainage
+ read(11) iWaFTV
+ ! AlbSTV : Dry Soil Albedo
+ read(11) AlbSTV
+ ! ivegTV : Vegetation Type Index
+ read(11) ivegTV
+ ! ifraTV : Vegetation Class Coverage
+ read(11) ifraTV
+ ! alaiTV : Leaf Area Index [-]
+ read(11) alaiTV
+ ! glf_TV : Green Leaf Fraction [-]
+ read(11) glf_TV
+ ! TsolTV : Soil Temperature [K]
+ read(11) TsolTV
+ ! eta_TV : Soil Moisture [m3/m3]
+ read(11) eta_TV
+
+ ! +--If Simulation start, then initialize further
+ ! + --------------------------------------------
+ if(itexpe == 0) then
+ do j = 1, my
+ do i = 1, mx
+ if(isolSL(i, j) == 1) then
+ ifraTV(i, j, 1) = 100
+ ivegTV(i, j, 1) = 0
+ isolTV(i, j) = 0
+#if(OA)
+ AlbSTV(i, j) = 0.15
+#endif
+ endif
+ if(isolSL(i, j) == 5) then
+ tsrfSL(i, j, 1) = 0.0d+0
+ do n = 1, nvx
+ tsrfSL(i, j, 1) = tsrfSL(i, j, 1) + TsolTV(i, j, n, 1) * ifraTV(i, j, n)
+ enddo
+ tsrfSL(i, j, 1) = tsrfSL(i, j, 1) * 1.0d-2
+ albsSL(i, j) = AlbSTV(i, j)
+ alb0SL(i, j) = albsSL(i, j)
+ albeSL(i, j) = albsSL(i, j)
+ if(tsrfSL(i, j, 1) < 200.) then
+ write(6, 6000) i, j
+6000 format(' WARNING: undefined Surface Temperature (i j) = (', 2i4, ')')
+ endif
+ endif
+ ! +--Set of SISVAT Variables
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ if(VSISVAT) then
+ if(isolSL(i, j) <= 2) then
+ ifraTV(i, j, 1) = 100
+ ivegTV(i, j, 1) = 0
+ isolTV(i, j) = 0
+ if(reaVAR .and. reaLBC) then
+ do n = 1, nvx
+ TvegTV(i, j, n) = sst_LB(i, j)
+ do k = 1, llx
+ TsolTV(i, j, n, k) = sst_LB(i, j)
+ eta_TV(i, j, n, k) = 1.
+ enddo
+ enddo
+ else
+ do n = 1, nvx
+ TvegTV(i, j, n) = SST_SL
+ do k = 1, llx
+ TsolTV(i, j, n, k) = SST_SL
+ eta_TV(i, j, n, k) = 1.
+ enddo
+ enddo
+ endif
+ else
+ if(.not. reaLBC) then
+ do n = 1, nvx
+ TvegTV(i, j, n) = SST_SL
+ enddo
+ else
+ do n = 1, nvx
+ TvegTV(i, j, n) = TairSL(i, j)
+ enddo
+ endif
+ endif
+ endif
+ do n = 1, max(mw, nvx)
+ n1 = min(n, mw)
+ n2 = min(n, nvx)
+ tsrfSL(i, j, n1) = TsolTV(i, j, n2, 1)
+ enddo
+ enddo
+ enddo
+#if(iso)
+ ! isotopic initialization of soil
+ call mariso_init_tv(iso_init_type, eta_TV, eta_TV_iso)
+#endif
+
+ if(iniWRI) then
+ n = 123
+ i50 = min(mx, 66)
+ j50 = min(my, 66)
+ vartyp = 'isolTV'
+ write(4, 4001) vartyp, n,((isolTV(i, j), i=1, i50), j=j50, 1, -1)
+4001 format(/, ' --- svasav --- ', a6, ' ---', i4, ' ---', /,(66i2))
+4002 format(/, ' --- svasav --- ', a6, ' ---', i4, ' ---', /,(66f6.2))
+ vartyp = 'iWaFTV'
+ write(4, 4001) vartyp, n,((iWaFTV(i, j), i=1, i50), j=j50, 1, -1)
+ do n = 1, nvx
+ vartyp = 'ifraTV'
+ write(4, 4002) vartyp, n,((ifraTV(i, j, n), i=1, i50), j=j50, 1, -1)
+ vartyp = 'ivegTV'
+ write(4, 4001) vartyp, n,((ivegTV(i, j, n), i=1, i50), j=j50, 1, -1)
+ enddo
+ iniWRI = .false.
+ endif
+ endif
+
+ ! +--If SISVAT is set up
+ ! + ~~~~~~~~~~~~~~~~~~~
+ if(VSISVAT .and. .not. reaVAR) then
+ do j = 1, my
+ do i = 1, mx
+ sst_LB(i, j) = SST_SL
+ sst1LB(i, j) = SST_SL
+ sst2LB(i, j) = SST_SL
+ enddo
+ enddo
+ endif
+
+ ! +--If Simulation start, then set to zero
+ ! + -------------------------------------
+ if(itexpe == 0) then
+ do msc = 1, nvx
+ do jjm = 1, jmx
+ do iim = 1, imx
+ CaSnTV(iim, jjm, msc) = 0.0
+ CaWaTV(iim, jjm, msc) = 0.0
+ WEq_SN(iim, jjm, msc) = 0.0
+ enddo
+ enddo
+ enddo
+ do msc = 1, nsx
+ do jjm = 1, jmx
+ do iim = 1, imx
+ snohSN(iim, jjm, msc) = 0.0
+#if(iso)
+ do wiso = 1, niso
+ snohSN_iso(wiso, iim, jjm, msc) = 0.0
+ enddo
+#endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! +--If Simulation restart, then read further
+ ! + ----------------------------------------
+ if(itexpe /= 0 .and. reaVAR) then
+ ! CaSnTV : Canopy Intercepted Snow Content[kg/m2]
+ read(11) CaSnTV
+ ! CaWaTV : Canopy Intercepted Water Content [kg/m2]
+ read(11) CaWaTV
+ ! psivTV : Vegetation Hydraulic Potential [m]
+ read(11) psivTV
+ ! psigTV : Ground Hydraulic Potential [m]
+ read(11) psigTV
+ ! TvegTV : Skin Vegetation Temperature [K]
+ read(11) TvegTV
+ ! TgrdTV : Skin Soil Temperature [K]
+ read(11) TgrdTV
+ do msc = 1, nvx
+ do jjm = 1, jmx
+ do iim = 1, imx
+ if(CaWaTV(iim, jjm, msc) <= 1.d-20) then
+ CaWaTV(iim, jjm, msc) = 0.d+00
+ endif
+ enddo
+ enddo
+ enddo
+ ! Total evapTV : Evapotranspiration [mm w.e.]
+ read(11) evapTV
+ ! draiTV : Drainage Flow [mm/s]
+ read(11) draiTV
+ ! runoTV : Integrated Drainage Flow [mm]
+ read(11) runoTV
+
+ ! +--Snow Pack Characteristics
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(mw /= 5) then
+ ! mskSNo2 : Snow/Ice Type Index [-]
+ read(11) mskSNo2
+ do i = 1, mx
+ do j = 1, my
+ mskSNo(i, j, 1) = mskSNo2(i, j)
+ enddo
+ enddo
+ else
+ ! mskSNo : Snow/Ice Type Index [-]
+ read(11) mskSNo
+ endif
+ ! nssSNo : Nb Snow and Ice Layers
+ read(11) nssSNo
+ ! issSNo : Nb Superimposed Ice Layers
+ read(11) issSNo
+ ! nisSNo : Nb Ice Layers
+ read(11) nisSNo
+ ! nhsSNo : Snow History [-]
+ read(11) nhsSNo
+ ! dzsSNo : Snow Layers Thickness [m]
+ read(11) dzsSNo
+ ! rosSNo : Snow Volumic Mass [kg/m3]
+ read(11) rosSNo
+ ! wasSNo : Snow Water Content [kg/kg]
+ read(11) wasSNo
+ ! tisSNo : Snow Temperature [K]
+ read(11) tisSNo
+ ! g1sSNo : Snow Dendricity / Sphericity [-]
+ read(11) g1sSNo
+ ! g2sSNo : Snow Sphericity / Size [-] [0.0001 m]
+ read(11) g2sSNo
+ ! agsSNo : Snow Age [day]
+ read(11) agsSNo
+ do n = 1, nsno
+ do k = 1, nsx
+ do j = 1, my
+ do i = 1, mx
+ if(agsSNo(i, j, k, n) <= 1000 .and. dzsSNo(i, j, k, n) > 0) then
+ agsSNo(i, j, k, n) = real(jdarGE + njyrGE(mmarGE)) / 365.+iyrrGE
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ ! snohSN : Snow Buffer Layer [kg/m2], [mm]
+ read(11) snohSN
+ ! BrosSN : Snow Buffer Layer Density [kg/m3]
+ read(11) BrosSN
+ ! BG1sSN : Snow Buffer Layer Dendri/Spher. [-]
+ read(11) BG1sSN
+ ! BG2sSN : Snow Buffer Layer Spheri/Size [-] [0.0001 m]
+ read(11) BG2sSN
+ ! SWaSNo : Snow Surficial Water [m]
+ read(11) SWaSNo
+ ! zWE0SN : Initial Snow Thickn.[mm w.e.]
+ read(11) zWE0SN
+ ! zWE_SN : Current Snow Thickn.[mm w.e.]
+ read(11) zWE_SN
+ ! zWEcSN : Non-erodible Snow Thickn.[mm w.e.]
+ read(11) zWEcSN
+ ! SaltSN : u*_th [m/s]
+ read(11) SaltSN
+ ! SLussl : u*_s* [kg/kg.m/s]
+ read(11) SLussl
+ ! blowSN : NEW MAX Erosion [kg/m2]
+ read(11) blowSN
+ ! WEq_SN : Added Snow Amount [m w.e.]
+ read(11) WEq_SN
+ ! SLn_z0 : Z0_momentum (instantaneous) [m]
+ read(11) SLn_z0
+ ! SLn_r0 : Z0_scalar (instantaneous) [m]
+ read(11) SLn_r0
+#if(BS)
+ ! SLn_b0 : Z0_erosion (instantaneous) [m]
+ read(11) SLn_b0
+#endif
+#if(ZA)
+ ! ua_0BS : Wind, x-component (t-dt) [m/s]
+ read(11) ua_0BS
+ ! va_0BS : Wind, y-component (t-dt) [m/s]
+ read(11) va_0BS
+ ! VVs_BS : (wind, Sastrugi) Relevance [m/s]
+ read(11) VVs_BS
+ ! RRs_BS : (wind, Sastrugi) Counter [-]
+ read(11) RRs_BS
+ ! DDs_BS : (wind, Sastrugi) Angle [dg]
+ read(11) DDs_BS
+ ! Z0SaBS : Z0(Sastrugi Height) [m]
+ read(11) Z0SaBS
+#endif
+ read(11) wes_IB ! Snow/ice Sublimation [mm w.e.]
+ read(11) weetIB ! Evapotranspiration [mm w.e.]
+ wee_IB(:, :, :, 3) = wes_IB(:, :, :)
+ wee_IB(:, :, :, 1) = weetIB(:, :, :)
+ read(11) wem_IB ! Snow/ice M < ng [mm w.e.]
+ read(11) wer_IB ! Snow/ice Refreezing [mm w.e.]
+ read(11) wei0IB ! Bottom Snow/ice added [mm w.e.]
+ read(11) weu_IB ! Run-off [mm w.e.]
+ read(11) zn0IB ! Initial Snow Height [m]
+ read(11) mb0IB ! Initial Mass Balance [mmWE]
+ if(mw == 5) then
+ read(11) gradTM !*CL* Local temp. gradient [C/m]
+ read(11) gradQM !*CL* Local hum. gradient [g/kg/m]
+ endif
+#if(iso)
+ ! read isotopic composition of water in the soil
+ open(unit=12, status='old', form='unformatted', file='MARsvt_iso.DAT')
+ ! rosSNo_iso : Snow Volumic Mass [kg/m3]
+ read(12) rosSNo_iso
+ ! wasSNo_iso: Soil humidity content (=> in the snow cover ) [kg/kg]
+ read(12) wasSNo_iso
+ ! SWaSNo_iso: Surficial Water Mass [kg/m2]
+ read(12) SWaSNo_iso
+ ! snohSN_iso : Snow Buffer Layer Thickness [mmWE]
+ read(12) snohSN_iso
+ ! eta_TV_iso : Soil Moisture Content [m3/m3]
+ read(12) eta_TV_iso
+ close(unit=12)
+#endif
+ else if(itexpe == 0) then
+ do j = 1, my
+ do i = 1, mx
+ evapTV(i, j) = 0.0
+#if(ZA)
+ VVs_BS(i, j) = 10.0
+ RRs_BS(i, j) = 1.0
+ DDs_BS(i, j) = 0.0
+#endif
+ enddo
+ enddo
+ endif
+
+ close(unit=11)
+
+ ! +--SVAT Prescribed Evolutive VBC (Vegetation Boundary Condition)
+ ! + (i.e., Green Leaf Fraction)
+ ! + -------------------------------------------------------------
+ tim1VB = ou2sGE(iyrSVA, mmaSVA, jdaSVA, jhuSVA, 0, 0)
+ tim2VB = tim1VB
+ do n = 1, nvx
+ do j = 1, my
+ do i = 1, mx
+#if(LN)
+ LAI1VB(i, j, n) = alaiTV(i, j, n)
+ LAI2VB(i, j, n) = alaiTV(i, j, n)
+#endif
+ glf1VB(i, j, n) = glf_TV(i, j, n)
+ glf2VB(i, j, n) = glf_TV(i, j, n)
+ enddo
+ enddo
+ enddo
+#if(GL)
+ ! MAR-GRISLI coupling
+ call ice_sheet_model_coupling
+#endif
+ endif
+
+ ! +--write
+ ! + =====
+ if(ordr == 'writ') then
+ open(unit=11, status='unknown', form='unformatted', file='MARsvt.DAT')
+ write(11) itexpe
+ write(11) iyrrGE, mmarGE, jdarGE, jhurGE
+ ! IOi_TV : IO i Index
+ write(11) IOi_TV
+ ! IOj_TV : IO j Index
+ write(11) IOj_TV
+ ! isolTV : Soil Type Index
+ write(11) isolTV
+ ! iWaFTV : =0 ==> no Water Flux =1 ==> free Drainage
+ write(11) iWaFTV
+ ! AlbSTV : Dry Soil Albedo
+ write(11) AlbSTV
+ ! ivegTV : Vegetation Type Index
+ write(11) ivegTV
+ ! ifraTV : Vegetation Class Coverage
+ write(11) ifraTV
+ ! alaiTV : Leaf Area Index [-]
+ write(11) alaiTV
+ ! glf_TV : Green Leaf Fraction [-]
+ write(11) glf_TV
+ ! TsolTV : Soil Temperature [K]
+ write(11) TsolTV
+ ! eta_TV : Soil Moisture [m3/m3]
+ write(11) eta_TV
+ ! CaSnTV : Canopy Intercepted Snow Content[m w.e.]
+ write(11) CaSnTV
+ ! CaWaTV : Canopy Intercepted Water Content [kg/m2]
+ write(11) CaWaTV
+ ! psivTV : Vegetation Hydraulic Potential [m]
+ write(11) psivTV
+ ! psigTV : Ground Hydraulic Potential [m]
+ write(11) psigTV
+ ! TvegTV : Skin Vegetation Temperature [K]
+ write(11) TvegTV
+ ! TgrdTV : Skin Soil Temperature [K]
+ write(11) TgrdTV
+ ! evapTV : Total Evapotranspiration [mm w.e.]
+ write(11) evapTV
+ ! draiTV : Drainage Flow [mm/s]
+ write(11) draiTV
+ ! runoTV : Integrated Drainage Flow [mm]
+ write(11) runoTV
+ do i = 1, mx
+ do j = 1, my
+ mskSNo2(i, j) = mskSNo(i, j, 1)
+ enddo
+ enddo
+ ! +--Snow Pack Characteristics
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~
+ if(mw /= 5) then
+ ! mskSNo2 : Snow/Ice Type Index [-]
+ write(11) mskSNo2
+ else
+ ! mskSNo : Snow/Ice Type Index [-]
+ write(11) mskSNo
+ endif
+ ! nssSNo : Nb Snow and Ice Layers
+ write(11) nssSNo
+ ! issSNo : Nb Superimposed Ice Layers
+ write(11) issSNo
+ ! nisSNo : Nb Ice Layers
+ write(11) nisSNo
+ ! nhsSNo : Snow History [-]
+ write(11) nhsSNo
+ ! dzsSNo : Snow Layers Thickness [m]
+ write(11) dzsSNo
+ ! rosSNo : Snow Volumic Mass [kg/m3]
+ write(11) rosSNo
+ ! wasSNo : Snow Water Content [m3/m3]
+ write(11) wasSNo
+ ! tisSNo : Snow Temperature [K]
+ write(11) tisSNo
+ ! g1sSNo : Snow Dendricity / Sphericity [-]
+ write(11) g1sSNo
+ ! g2sSNo : Snow Sphericity / Size [-] [0.0001 m]
+ write(11) g2sSNo
+ ! agsSNo : Snow Age [day]
+ write(11) agsSNo
+ ! snohSN : Snow Buffer Layer [kg/m2], [mm]
+ write(11) snohSN
+ ! BrosSN : Snow Buffer Layer Density [kg/m3]
+ write(11) BrosSN
+ ! BG1sSN : Snow Buffer Layer Dendri/Spher. [-]
+ write(11) BG1sSN
+ ! BG2sSN : Snow Buffer Layer Spheri/Size [-] [0.0001 m]
+ write(11) BG2sSN
+ ! SWaSNo : Snow Surficial Water [m]
+ write(11) SWaSNo
+ ! zWE0SN : Initial Snow Thickness [mm w.e.]
+ write(11) zWE0SN
+ ! zWE_SN : Current Snow Thickness [mm w.e.]
+ write(11) zWE_SN
+ ! zWEcSN : Non-erodible Snow Thickness [mm w.e.]
+ write(11) zWEcSN
+ ! SaltSN : u*_th [m/s]
+ write(11) SaltSN
+ ! SLussl : u*_s* [kg/kg.m/s]
+ write(11) SLussl
+ ! blowSN : NEW MAX Erosion [kg/m2]
+ write(11) blowSN
+ ! WEq_SN : Added Snow Amount [m w.e.]
+ write(11) WEq_SN
+ ! SLn_z0 : Z0_momentum (instantaneous) [m]
+ write(11) SLn_z0
+ ! SLn_r0 : Z0_scalar (instantaneous) [m]
+ write(11) SLn_r0
+#if(BS)
+ ! SLn_b0 : Z0_erosion (instantaneous) [m]
+ write(11) SLn_b0
+#endif
+#if(ZA)
+ ! ua_0BS : Wind, x-component (t-dt) [m/s]
+ write(11) ua_0BS
+ ! va_0BS : Wind, y-component (t-dt) [m/s]
+ write(11) va_0BS
+ ! VVs_BS : (wind, Sastrugi) Relevance [m/s]
+ write(11) VVs_BS
+ ! RRs_BS : (wind, Sastrugi) Counter [-]
+ write(11) RRs_BS
+ ! DDs_BS : (wind, Sastrugi) Angle [dg]
+ write(11) DDs_BS
+ ! Z0SaBS : Z0 (Sastrugi Height) [m]
+ write(11) Z0SaBS
+#endif
+ ! wes_IB : Snow/ice Sublimation [mm w.e.]
+ write(11) wes_IB
+ ! wee_IB : Evapotranspiration [mm w.e.]
+ write(11) weetIB
+ wes_IB(:, :, :) = wee_IB(:, :, :, 3)
+ weetIB(:, :, :) = wee_IB(:, :, :, 1)
+ ! wem_IB : Snow/ice M < ng [mm w.e.]
+ write(11) wem_IB
+ ! wer_IB : Snow/ice Refreezing [mm w.e.]
+ write(11) wer_IB
+ ! wei0IB : Bottom Snow/ice added [mm w.e.]
+ write(11) wei0IB
+ ! weu_IB : Run-off [mm w.e.]
+ write(11) weu_IB
+ ! zn0IB : Initial Snow Height [m]
+ write(11) zn0IB
+ ! mb0IB : Initial Mass Balance [mmWE]
+ write(11) mb0IB
+ if(mw == 5) then
+ ! gradTM :*CL* Local temp. gradient [C/m]
+ write(11) gradTM
+ ! gradQM :*CL* Local hum. gradient [g/kg/m]
+ write(11) gradQM
+ endif
+ close(unit=11)
+#if(iso)
+ ! write isotopic composition of water in the soil
+ open(unit=11, status='unknown', form='unformatted', file='MARsvt_iso.DAT')
+ ! rosSNo_iso : Snow Volumic Mass [kg/m3]
+ write(11) rosSNo_iso
+ ! wasSNo_iso: Soil humidity content (=> in the snow cover ) [kg/kg]
+ write(11) wasSNo_iso
+ ! SWaSNo_iso: Surficial Water Mass [kg/m2]
+ write(11) SWaSNo_iso
+ ! snohSN_iso : Snow Buffer Layer Thickness [mmWE]
+ write(11) snohSN_iso
+ ! eta_TV_iso : Soil Moisture Content [m3/m3]
+ write(11) eta_TV_iso
+ close(unit=11)
+#endif
+ endif
+ return
+endsubroutine svasav
diff --git a/MAR/code_mar/timcor.f90 b/MAR/code_mar/timcor.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c65145e8015387203ce8a5c4a5a664b4b6ace100
--- /dev/null
+++ b/MAR/code_mar/timcor.f90
@@ -0,0 +1,50 @@
+subroutine TIMcor(i, j)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TIME 30-11-2000 MAR |
+ ! | subroutine TIMcor computes Corrected Local Times |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ jhurGE : Universal Time (Hour UT) |
+ ! | itizGE(i,j): Time Zone of Grid Point (i,j) |
+ ! | jhlrGE(i,j): Local Time at Grid Point (i,j) (Hour LT) |
+ ! | mmarGE : Month |
+ ! | jdarGE : Day |
+ ! | |
+ ! | OUTPUT: mmplus : Month (corrected) |
+ ! | ^^^^^^^ jdplus : Day (corrected) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+
+ implicit none
+
+ integer, intent(in) :: i
+ integer, intent(in) :: j
+
+ ! +--Corrected Time Base
+ ! + ===================
+
+ jdplus = jdarGE
+ if(jhurGE + itizGE(i, j) < jhlrGE(i, j)) jdplus = jdarGE - 1
+ if(jhurGE + itizGE(i, j) > jhlrGE(i, j)) jdplus = jdarGE + 1
+ if(jdplus == 0) then
+ mmplus = mmarGE - 1 + 12
+ mmplus = mod(mmplus, 12)
+ jdplus = njmoGE(mmplus)
+ else
+ if(jdplus > njmoGE(mmarGE)) then
+ mmplus = mmarGE + 1
+ jdplus = 1
+ else
+ mmplus = mmarGE
+ endif
+ endif
+
+ return
+endsubroutine TIMcor
diff --git a/MAR/code_mar/timcur.f90 b/MAR/code_mar/timcur.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1f4af99031373f70c3f8d095f3ade8751627bf7b
--- /dev/null
+++ b/MAR/code_mar/timcur.f90
@@ -0,0 +1,36 @@
+subroutine timcur
+ ! +------------------------------------------------------------------------+
+ ! | MAR TIME 18-09-2001 MAR |
+ ! | subroutine timcur computes MAR Time |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ itexpe: Experiment Iteration Counter |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ jdaMAR: Nb of Days Since Run Beginning (i.e. itexpe = 0) |
+ ! | jhaMAR: Nb of Hours |
+ ! | jmmMAR: Nb of Minutes |
+ ! | jssMAR: Nb of Seconds |
+ ! | jhaRUN: Nb of Hours Since Run Beginning |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+
+ implicit none
+
+ ! +--MAR Time
+ ! + ========
+ jssMAR = itexpe * idt
+ jmmMAR = jssMAR / 60
+ jhaRUN = jmmMAR / 60
+ jdaMAR = jhaRUN / 24
+ jhaMAR = jhaRUN - jdaMAR * 24
+ jmmMAR = jmmMAR - (jdaMAR * 24 + jhaMAR) * 60
+ jssMAR = jssMAR - ((jdaMAR * 24 + jhaMAR) * 60 + jmmMAR) * 60
+ return
+endsubroutine timcur
diff --git a/MAR/code_mar/time_steps.f90 b/MAR/code_mar/time_steps.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c7b5b20c30598ef76763dbabf7bd071622f4861f
--- /dev/null
+++ b/MAR/code_mar/time_steps.f90
@@ -0,0 +1,152 @@
+#include "MAR_pp.def"
+subroutine time_steps
+ ! +------------------------------------------------------------------------+
+ ! | MAR time_steps 02-03-2022 MAR |
+ ! +------------------------------------------------------------------------+
+
+ use mardim
+ use mar_ge
+ use margrd
+ use marphy
+ use marctr
+ use mar_sv
+ use marssn
+ use mar_ib
+
+ implicit none
+
+ character(8) :: date_mar
+ character(10) :: time_mar
+
+ real dt_base, new_dt
+
+ new_dt = dt
+
+ if(mod(int(real(3600.*24./OutdyIB) / dt), 1) /= 0) dt = dt - 5
+
+ if(dt > 300) new_dt = 300
+ if(dx <= 35000 .and. dt > 240) new_dt = 240
+ if(dx <= 30000 .and. dt > 200) new_dt = 200
+ if(dx <= 25000 .and. dt > 180) new_dt = 180
+ if(dx <= 20000 .and. dt > 150) new_dt = 150
+ if(dx <= 15000 .and. dt > 120) new_dt = 120
+ if(dx <= 10000 .and. dt > 90) new_dt = 90
+ if(dx <= 5000 .and. dt > 60) new_dt = 60
+ if(dx <= 2500 .and. dt > 30) new_dt = 30
+
+ if(dt > 240 .and. dt < 300) new_dt = 240
+ if(dt > 200 .and. dt < 240) new_dt = 200
+ if(dt > 180 .and. dt < 200) new_dt = 180
+ if(dt > 150 .and. dt < 180) new_dt = 150
+ if(dt > 120 .and. dt < 150) new_dt = 120
+ if(dt > 100 .and. dt < 120) new_dt = 100
+ if(dt > 90 .and. dt < 100) new_dt = 90
+ if(dt > 80 .and. dt < 90) new_dt = 80
+ if(dt > 75 .and. dt < 80) new_dt = 75
+ if(dt > 60 .and. dt < 75) new_dt = 60
+ if(dt > 50 .and. dt < 60) new_dt = 50
+ if(dt > 45 .and. dt < 50) new_dt = 45
+ if(dt > 40 .and. dt < 45) new_dt = 40
+ if(dt > 30 .and. dt < 40) new_dt = 30
+ if(dt > 25 .and. dt < 30) new_dt = 25
+ if(dt > 20 .and. dt < 25) new_dt = 20
+ if(dt > 15 .and. dt < 20) new_dt = 15
+ if(dt > 10 .and. dt < 15) new_dt = 10
+ if(dt > 8 .and. dt < 10) new_dt = 8
+ if(dt > 5 .and. dt < 8) new_dt = 5
+ if(dt > 2 .and. dt < 5) new_dt = 2
+ if(dt < 2) stop
+
+ if(dt /= new_dt) then
+
+ write(6, *)
+ write(6, 800) nint(dt), nint(new_dt)
+ write(6, *)
+800 format(" ERROR: The time step is too high!! ", i3, "s ->", i3, "s")
+
+ itexpe = nint(real(itexpe) * dt / new_dt)
+ nboucl = nint(real(nboucl) * dt / new_dt)
+ jtRadi2 = nint(real(jtRadi2) * dt / new_dt)
+
+ dt = new_dt
+ idt = dt
+ jdt = (dt - idt) * 100.
+ dtfast = dt / (ntFast + 1)
+
+ call timgeo()
+
+ endif
+
+ ! -----------------------------------------------------------------
+
+ dt_base = 60.
+ if(dt > 60) dt_base = min(dt / 2., dt_base)
+
+ ! -----------------------------------------------------------------
+
+ jtRadi2 = min(int(real(3600.*24./OutdyIB) / dt), jtRadi2)
+
+ ! ! characteristic time of radCEP (3600s)
+ jtRadi2 = max(900 / int(dt), jtRadi2) ! 15 min
+ jtRadi2 = min(3 * 3600 / int(dt), jtRadi2) ! 3h
+
+ if(600./real(jtRadi2) /= 600 / jtRadi2) &
+ jtRadi2 = max(900 / int(dt), jtRadi2)
+
+ if(900./real(jtRadi2) /= 900 / jtRadi2) &
+ jtRadi2 = max(1200 / int(dt), jtRadi2)
+
+ if(1200./real(jtRadi2) /= 1200 / jtRadi2) &
+ jtRadi2 = max(1800 / int(dt), jtRadi2)
+
+ if(1800./real(jtRadi2) /= 1800 / jtRadi2) &
+ jtRadi2 = max(3600 / int(dt), jtRadi2)
+
+ jtRadi = jtRadi2
+
+ ! -----------------------------------------------------------------
+
+ ! ! characteristic time of sisvat (60s)
+ ntPhys = nint(dt / dt_base)
+ !c#BS ntPhys = max(2,ntPhys)
+
+ ! ! characteristic time of Hydmic (60s)
+ ntHyd = nint(dt / dt_base)
+ !c#BS ntHyd = max(2,ntHyd)
+
+ ! ! subgrid scale steps (turbulence and convection) (60s)
+ ntDiff = nint(dt / dt_base)
+ if(OutdyIB > 4) ntDiff = max(2, ntDiff)
+#if(BS)
+ ntDiff = max(2, ntDiff)
+#endif
+
+ ntPhys = min(3, max(1, ntPhys))
+ ntHyd = min(3, max(1, ntHyd))
+ ntDiff = min(2, max(1, ntDiff))
+
+ dtPhys = dt / real(ntPhys)
+ dtHyd = dt / real(ntHyd)
+ dtDiff = dt / real(ntDiff)
+
+ dtRadi = max(600., min(7200., dt * jtRadi)); jtRadi = real(dtRadi) / dt
+
+ ! -----------------------------------------------------------------
+
+ call date_and_time(DATE=date_mar)
+ call date_and_time(TIME=time_mar)
+
+ write(6, 400) jdarGE, mmarGE, iyrrGE, jhurGE, minuGE, jsecGE
+
+400 format(' MAR time : ', i2, '/', i2, '/', i4, ' ', i2, ':', i2, ':', i2)
+
+ write(6, *) "Real time : "//date_mar(5:6)//"/" &
+ //date_mar(7:8)//"/"//date_mar(1:4)//" "//time_mar(1:2) &
+ //":"//time_mar(3:4)//":"//time_mar(5:6)
+
+ write(6, 401) dt, dtHyd, dtDiff, dtRadi, nt_Mix
+401 format(' Step time : dt=', f5.1, ", dtHyd=", f5.1, &
+ ", dtDiff=", f5.1, ", dtRadi=", f6.0, ' s', &
+ ", nt_Mix=", i2)
+
+endsubroutine time_steps
diff --git a/MAR/code_mar/timgeo.f90 b/MAR/code_mar/timgeo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..deca8fcf11366a20224abea3addb67428bb66113
--- /dev/null
+++ b/MAR/code_mar/timgeo.f90
@@ -0,0 +1,92 @@
+subroutine timgeo
+ ! +------------------------------------------------------------------------+
+ ! | MAR TIME 1-11-2001 MAR |
+ ! | subroutine timgeo computes Current Universal and Local Times |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ itexpe: Experiment Iteration Counter |
+ ! | itizGE(mx,my): Time Zone |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ iyrrGE : year |
+ ! | mmarGE : Month |
+ ! | jdarGE : Day |
+ ! | jhurGE : Universal Time (Hour UT) |
+ ! | jhlrGE(mx,my): Local Time (Hour LT) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+
+ implicit none
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ !XF
+ integer njmo, leap
+ integer(kind=8) jdarGE8, jhurGE8, minuGE8, jsecGE8
+ !XF
+
+ ! +--Universal Time
+ ! + ==============
+ iyrrGE = iyr0GE
+ mmarGE = mma0GE
+ jdarGE8 = jda0GE
+ jhurGE8 = jhu0GE
+ minuGE8 = 0
+ jsecGE8 = itexpe * idt
+240 continue
+ if(jsecGE8 < 60) go to 241
+ jsecGE8 = jsecGE8 - 60
+ minuGE8 = minuGE8 + 1
+ go to 240
+241 continue
+ if(minuGE8 < 60) go to 242
+ minuGE8 = minuGE8 - 60
+ jhurGE8 = jhurGE8 + 1
+ go to 241
+242 continue
+ if(jhurGE8 < 24) go to 243
+ jhurGE8 = jhurGE8 - 24
+ jdarGE8 = jdarGE8 + 1
+ go to 242
+243 continue
+ !XF
+ leap = 1
+ if(mod(iyrrGE, 100) == 0 .and. mod(iyrrGE, 400) /= 0) leap = 0
+ !XF
+
+ njmo = njmoGE(mmarGE) &
+ + njmbGE(mmarGE) * max(0, 1 - mod(iyrrGE, 4)) &
+ * leap
+
+ if(jdarGE8 <= njmo) go to 244
+ jdarGE8 = jdarGE8 - njmo
+ mmarGE = mmarGE + 1
+ if(mmarGE <= 12) go to 243
+ mmarGE = mmarGE - 12
+ iyrrGE = iyrrGE + 1
+ go to 243
+244 continue
+
+ ! +--Local Time
+ ! + ==============
+ do j = 1, my
+ do i = 1, mx
+ jhlrGE(i, j) = jhurGE8 + itizGE(i, j)
+ if(jhlrGE(i, j) >= 24) jhlrGE(i, j) = jhlrGE(i, j) - 24
+ if(jhlrGE(i, j) < 0) jhlrGE(i, j) = jhlrGE(i, j) + 24
+ enddo
+ enddo
+ jdarGE = jdarGE8
+ jhurGE = jhurGE8
+ minuGE = minuGE8
+ jsecGE = jsecGE8
+ return
+endsubroutine timgeo
diff --git a/MAR/code_mar/tlat.f90 b/MAR/code_mar/tlat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5a9c2f9131990dd943b75b56f2be007cd371532e
--- /dev/null
+++ b/MAR/code_mar/tlat.f90
@@ -0,0 +1,60 @@
+subroutine tlat(tlat_a, tlat_b, tlat_c, tlat_d, tlat_p, tlat_q, nx, n, tlat_x)
+ ! +
+ ! +------------------------------------------------------------------------+
+ ! | MAR DYNAMICS FILTER 20-09-2001 MAR |
+ ! | subroutine tlat uses the Gaussian Elimination Algorithm |
+ ! | (e.g. Pielke (1984), pp.302--303) |
+ ! | (needed to solve the implicit scheme developped for filtering) |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: tlat_a,tlat_b,tlat_c: tri-diagional matrix coefficients |
+ ! | ^^^^^ tlat_d : tri-diagional matrix independent term |
+ ! | tlat_p,tlat_q : working variables |
+ ! | n : dimension of the variables |
+ ! | ix : switch |
+ ! | tlat_x : variable to solve |
+ ! | |
+ ! | OUTPUT: tlat_x |
+ ! | ^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ ! +
+ implicit none
+ ! +
+ integer nx, n
+ real tlat_a(nx), tlat_b(nx), tlat_c(nx), tlat_d(nx)
+ real tlat_x(nx), tlat_p(nx), tlat_q(nx)
+ ! +
+ integer k, l
+ integer ix
+ ! +
+ data ix/0/
+ ! +
+ ! +
+ ! +--Forward Sweep
+ ! + ==============
+ ! +
+ if(ix /= 1) then
+ tlat_p(1) = tlat_b(1)
+ tlat_q(1) = -tlat_c(1) / tlat_p(1)
+ do k = 2, n
+ tlat_p(k) = tlat_a(k) * tlat_q(k - 1) + tlat_b(k)
+ tlat_q(k) = -tlat_c(k) / tlat_p(k)
+ enddo
+ endif
+ ! +
+ tlat_x(1) = tlat_d(1) / tlat_p(1)
+ do k = 2, n
+ tlat_x(k) = (tlat_d(k) - tlat_a(k) * tlat_x(k - 1)) / tlat_p(k)
+ enddo
+ ! +
+ ! +
+ ! +--Backward Sweep
+ ! + ==============
+ ! +
+ do l = 2, n
+ k = n - l + 1
+ tlat_x(k) = tlat_q(k) * tlat_x(k + 1) + tlat_x(k)
+ enddo
+ ! +
+ return
+endsubroutine tlat
diff --git a/MAR/code_mar/trackwater_mod.f90 b/MAR/code_mar/trackwater_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6237a518a35c402a3c3d2179b52fb04e7a60dc04
--- /dev/null
+++ b/MAR/code_mar/trackwater_mod.f90
@@ -0,0 +1,130 @@
+! trackwater, Cécile Agosta, July 2022
+! track changes in water vapor (water budget)
+module trackwater
+ ! track_water : activation of trackwater in mar
+ logical, parameter :: track_water = .false.
+ ! track turabl : activation of trackwater in turabl, to distangle surface sublimation from mixing
+ logical, parameter :: track_water_turabl = .false.
+ ! track dynadv : activation of trackwater in dynadv_lfb_2p, to distangle horizontal from vertical advection
+ logical, parameter :: track_water_dynadv = .false.
+ ! ntwater : effective number of tracked water component
+ integer, save :: ntwater
+ ! water vapor
+ ! ===========
+ ! tracked components indexes
+ integer, save :: j_dynadv ! dynadv : LFB horizontal advection
+ integer, save :: j_turhor ! turhor : Horizontal diffusion
+ integer, save :: j_turabl ! turabl : Boundary Layer Turbulence
+ integer, save :: j_sspray ! sspray : Sea Spray
+ integer, save :: j_hydgen ! hydgen : Microphysics
+ integer, save :: j_lbcnud ! lbcnud : Lateral Boundary Condition
+ integer, save :: j_cvagen ! cvagen : Convection
+ ! index for turabl
+ integer, save :: j_turabl_mix ! turabl_mix : Mixing with other layers without surface sublimation
+ integer, save :: j_turabl_sbl ! turabl_sbl : Mixing of surface sublimation
+ ! index for dynadv_lfb_2p
+ integer, save :: j_dynadv_hor ! dynadv_hor : Horizontal advection
+ integer, save :: j_dynadv_ver ! dynadv_ver : Vertical advection
+ integer, save :: j_dynadv_sav ! dynadv_sav : Mass conservation operations
+ ! tracked components names
+ character(len = 3), allocatable, save :: name_water(:)
+ ! delta_qv : cumulative change in water vapor components (kg/kg)
+ real, allocatable, save :: delta_qv(:, :, :, :)
+ ! qvDY_save : Save state before routine call (kg/kg)
+ real, allocatable :: qvDY_save(:, :, :)
+ ! for out_nc outputs (kg/kg)
+ ! ==========================
+ real, allocatable, save :: delta_qv_NCsave(:, :, :, :)
+ ! ddelta_water = delta_qv - delta_qv_save (kg/kg)
+ real, allocatable :: ddelta_water(:, :, :)
+ ! for outice outputs
+ ! ==================
+ real, allocatable, save :: dqvIB(:, :, :, :) ! dqvIB : delta_qv in (g / kg) hour-1
+ real, allocatable, save :: delta_qv_IBsave(:, :, :, :) ! delta_qv_IBsave : delta_qv from previous time save (kg / kg)
+ ! temporary variables
+ integer jtw ! iteration for tracked water changes
+ real :: delta_qv_tmp ! temporary variable in turabl
+ real, allocatable :: dqp1_h(:, :, :) ! temporary variable in dynadv_lfb_2p
+ real, allocatable :: dqp1_v(:, :, :) ! temporary variable in dynadv_lfb_2p
+ real, allocatable :: dqm1_h(:, :, :) ! temporary variable in dynadv_lfb_2p
+ real, allocatable :: dqm1_v(:, :, :) ! temporary variable in dynadv_lfb_2p
+
+contains
+
+ subroutine trackwater_init()
+ use mardim, only : mx, my, mz
+ use mar_ib, only : ml
+ implicit none
+ ! ntwater : effective number of tracked water component
+ ! set up indexes
+ ntwater = 0
+ ntwater = ntwater + 1
+ j_dynadv = ntwater
+ ntwater = ntwater + 1
+ j_turhor = ntwater
+ ntwater = ntwater + 1
+ j_turabl = ntwater
+ ntwater = ntwater + 1
+ j_sspray = ntwater
+ ntwater = ntwater + 1
+ j_hydgen = ntwater
+ ntwater = ntwater + 1
+ j_lbcnud = ntwater
+ ntwater = ntwater + 1
+ j_cvagen = ntwater
+ if (track_water_turabl) then
+ ntwater = ntwater + 1
+ j_turabl_mix = ntwater
+ ntwater = ntwater + 1
+ j_turabl_sbl = ntwater
+ end if
+ if (track_water_dynadv) then
+ ntwater = ntwater + 1
+ j_dynadv_hor = ntwater
+ ntwater = ntwater + 1
+ j_dynadv_ver = ntwater
+ ntwater = ntwater + 1
+ j_dynadv_sav = ntwater
+ end if
+ allocate(name_water(ntwater))
+ ! set water names
+ name_water(j_dynadv) = 'adv'
+ name_water(j_turhor) = 'dif'
+ name_water(j_turabl) = 'tur'
+ name_water(j_sspray) = 'spr'
+ name_water(j_hydgen) = 'hyd'
+ name_water(j_lbcnud) = 'lbc'
+ name_water(j_cvagen) = 'cva'
+ if (track_water_turabl) then
+ name_water(j_turabl_mix) = 'mix'
+ name_water(j_turabl_sbl) = 'sbl'
+ end if
+ if (track_water_dynadv) then
+ name_water(j_dynadv_hor) = 'hor'
+ name_water(j_dynadv_ver) = 'ver'
+ name_water(j_dynadv_sav) = 'sav'
+ end if
+
+ ! allocates
+ allocate(qvDY_save(mx, my, mz))
+ allocate(delta_qv(mx, my, mz, ntwater))
+ allocate(delta_qv_NCsave(mx, my, mz, ntwater))
+ allocate(ddelta_water(mx, my, mz))
+ allocate(dqvIB(mx, my, ml, ntwater))
+ allocate(delta_qv_IBsave(mx, my, mz, ntwater))
+ ! initial values
+ qvDY_save = 0.
+ delta_qv = 0.
+ delta_qv_NCsave = 0.
+ ddelta_water = 0.
+ dqvIB = 0.
+ delta_qv_IBsave = 0.
+ ! temporary variables
+ delta_qv_tmp = 0.
+ if (track_water_dynadv) then
+ allocate(dqp1_h(mx, my, mz), dqp1_v(mx, my, mz))
+ allocate(dqm1_h(mx, my, mz), dqm1_v(mx, my, mz))
+ end if
+ endsubroutine trackwater_init
+
+endmodule trackwater
diff --git a/MAR/code_mar/trackwind_mod.f90 b/MAR/code_mar/trackwind_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9433c0f87b51790dd775b3d553ec53bb1aea24bd
--- /dev/null
+++ b/MAR/code_mar/trackwind_mod.f90
@@ -0,0 +1,146 @@
+! trackwind, Cécile Agosta, July 2022
+! track changes in winds (momentum budget)
+!
+module trackwind
+ implicit none
+ ! track_wind : activation of trackwind
+ logical, parameter :: track_wind = .false.
+ ! ntrackwind : number of routines changing winds tracked
+ integer, parameter :: ntrackwind = 6 ! ntrackwind : number of tracked routines
+ ! momentum : horizontal wind
+ ! ==========================
+ ! delta_u, delta_v : cumulative change in wind components
+ real, allocatable, save :: delta_u(:, :, :, :) ! (mx, my, mz, ntrackwind)
+ real, allocatable, save :: delta_v(:, :, :, :) ! (mx, my, mz, ntrackwind)
+ ! uairDY_save, vairDY_save : Save state before routine call
+ real, allocatable :: uairDY_save(:, :, :)
+ real, allocatable :: vairDY_save(:, :, :)
+ ! define tracked routines
+ integer itw ! iteration for tracked wind chances
+ character(len = 6), parameter :: name_wind(ntrackwind) = (/ 'dgz', 'fil', 'cor', 'dif', 'tur', 'lbc' /)
+ ! index in the array
+ integer, parameter :: i_dyndgz = 1 ! dyndgz : Horizontal Pressure Gradient Force
+ integer, parameter :: i_dynfil = 2 ! dynfil : Horizontal filtering
+ integer, parameter :: i_coriol = 3 ! coriol : Coriolis
+ integer, parameter :: i_turhor = 4 ! turhor : Horizontal diffusion
+ integer, parameter :: i_turabl = 5 ! turabl : Boundary Layer Turbulence
+ integer, parameter :: i_lbcnud = 6 ! lbcnud : Lateral Boundary Condition
+ ! for out_nc outputs
+ real, allocatable, save :: delta_u_NCsave(:, :, :, :) ! (mx, my, mz, ntrackwind)
+ real, allocatable, save :: delta_v_NCsave(:, :, :, :) ! (mx, my, mz, ntrackwind)
+ ! ddelta_var = delta_var - delta_var_save
+ real, allocatable :: ddelta_var(:, :, :)
+ ! for outice outputs
+ real, allocatable, save :: duIB(:, :, :, :) ! duIB : delta_u in m s-1 h-1
+ real, allocatable, save :: dvIB(:, :, :, :) ! dvIB : delta_v in m s-1 h-1
+ real, allocatable, save :: delta_u_IBsave(:, :, :, :) ! delta_u_IBsave : delta_u from previous time save
+ real, allocatable, save :: delta_v_IBsave(:, :, :, :) ! delta_v_IBsave : delta_v from previous time save
+ ! track dyndgz
+ ! track_dgz : activation of trackwind in dyndgz
+ logical, parameter :: track_dgz = .false.
+ ! ntrackdgz : number of contribution to dgz tracked
+ integer, parameter :: ntrackdgz = 2 ! ntrackdgz : number of tracked contribution in dyndgz
+ ! delta_u_dgz, delta_v_dgz : cumulative change in wind components
+ real, allocatable, save :: delta_u_dgz(:, :, :, :)
+ real, allocatable, save :: delta_v_dgz(:, :, :, :)
+ character(len = 6), parameter :: name_dgz(ntrackdgz) = (/ 'adv', 'pgf' /)
+ ! index in the array
+ integer, parameter :: i_dgzadv = 1 ! dgzadv : Advection contribution to Horizontal PGF
+ integer, parameter :: i_dgzpgf = 2 ! dgzpgf : Horizontal PGF
+ ! for out_nc outputs
+ real, allocatable, save :: delta_u_dgz_NCsave(:, :, :, :)
+ real, allocatable, save :: delta_v_dgz_NCsave(:, :, :, :)
+ ! for outice outputs
+ real, allocatable, save :: dudgzIB(:, :, :, :) ! dudgzIB : delta_u_dgz in m s-1 h-1
+ real, allocatable, save :: dvdgzIB(:, :, :, :) ! dvdgzIB : delta_v_dgz in m s-1 h-1
+ real, allocatable, save :: delta_u_dgz_IBsave(:, :, :, :) ! delta_u_dgz_IBsave : delta_u_dgz from previous time save
+ real, allocatable, save :: delta_v_dgz_IBsave(:, :, :, :) ! delta_v_dgz_IBsave : delta_v_dgz from previous time save
+ ! temporary variables
+ real :: dudt_t
+ real, allocatable :: dudt_tm1(:, :, :, :)
+ real :: c1a_t(ntrackdgz)
+ real, allocatable :: c1a_tm1(:, :, :, :)
+ real, allocatable :: c1a_tm2(:, :, :, :)
+
+ ! ! momentum : vertical wind psig
+ ! ! =============================
+ ! real :: psigDY_save(mx, my, mz) ! Save state before routine call
+ ! ! dyndps : Mass Continuity
+ ! real, save :: dp_dyndps(mx, my, mz)
+ ! ! dynfil : Filtering
+ ! real, save :: dp_dynfil(mx, my, mz)
+ ! ! water : qv
+ ! real :: qvDY_save(mx, my, mz) ! Save state before routine call
+ ! real, save :: dq_dynadv(mx, my, mz) ! Advection
+ ! real, save :: dq_turhor(mx, my, mz) ! Horizontal diffusion
+ ! real, save :: dq_turabl(mx, my, mz) ! Turbulence
+ ! real, save :: dq_sspray(mx, my, mz) ! Sea spray
+ ! real, save :: dq_hydgen(mx, my, mz) ! Microphysics
+ ! real, save :: dq_lbcnud(mx, my, mz) ! Lateral boundaries
+ ! real, save :: dq_cvagen(mx, my, mz) ! Convection
+
+contains
+
+ subroutine trackwind_init()
+ use mardim, only : mx, my, mz
+ use mar_ib, only : ml
+ implicit none
+ ! allocates
+ allocate(uairDY_save(mx, my, mz))
+ allocate(vairDY_save(mx, my, mz))
+ allocate(delta_u(mx, my, mz, ntrackwind))
+ allocate(delta_v(mx, my, mz, ntrackwind))
+ allocate(delta_u_NCsave(mx, my, mz, ntrackwind))
+ allocate(delta_v_NCsave(mx, my, mz, ntrackwind))
+ allocate(ddelta_var(mx, my, mz))
+ allocate(duIB(mx, my, ml, ntrackwind))
+ allocate(dvIB(mx, my, ml, ntrackwind))
+ allocate(delta_u_IBsave(mx, my, mz, ntrackwind))
+ allocate(delta_v_IBsave(mx, my, mz, ntrackwind))
+ ! initial values
+ uairDY_save = 0.
+ vairDY_save = 0.
+ delta_u = 0.
+ delta_v = 0.
+ delta_u_NCsave = 0.
+ delta_v_NCsave = 0.
+ ddelta_var = 0.
+ duIB = 0.
+ dvIB = 0.
+ delta_u_IBsave = 0.
+ delta_v_IBsave = 0.
+ end subroutine trackwind_init
+
+ subroutine trackdgz_init()
+ use mardim, only : mx, my, mz
+ use mar_ib, only : ml
+ implicit none
+ ! allocates
+ allocate(delta_u_dgz(mx, my, mz, ntrackdgz))
+ allocate(delta_v_dgz(mx, my, mz, ntrackdgz))
+ allocate(delta_u_dgz_NCsave(mx, my, mz, ntrackdgz))
+ allocate(delta_v_dgz_NCsave(mx, my, mz, ntrackdgz))
+ allocate(dudgzIB(mx, my, ml, ntrackdgz))
+ allocate(dvdgzIB(mx, my, ml, ntrackdgz))
+ allocate(delta_u_dgz_IBsave(mx, my, mz, ntrackdgz))
+ allocate(delta_v_dgz_IBsave(mx, my, mz, ntrackdgz))
+ allocate(dudt_tm1(mx, my, mz, ntrackdgz))
+ allocate(c1a_tm1(mx, my, mz, ntrackdgz))
+ allocate(c1a_tm2(mx, my, mz, ntrackdgz))
+ ! initial values
+ delta_u_dgz = 0.
+ delta_v_dgz = 0.
+ delta_u_dgz_NCsave = 0.
+ delta_v_dgz_NCsave = 0.
+ dudgzIB = 0.
+ dvdgzIB = 0.
+ delta_u_dgz_IBsave = 0.
+ delta_v_dgz_IBsave = 0.
+ dudt_t = 0.
+ dudt_tm1 = 0.
+ c1a_t = 0.
+ c1a_tm1 = 0.
+ c1a_tm2 = 0.
+ end subroutine trackdgz_init
+
+end module trackwind
diff --git a/MAR/code_mar/turabl.f90 b/MAR/code_mar/turabl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3cf67c5f0aa325b5ca85152f79da314ca4b2e444
--- /dev/null
+++ b/MAR/code_mar/turabl.f90
@@ -0,0 +1,1338 @@
+#include "MAR_pp.def"
+subroutine TURabl
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE (ABL) 10-05-2021 MAR |
+ ! | subroutine TURabl includes the Contribution of Vertical Turbulence |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ micphy : Cloud Microphysics Switch |
+ ! | dt_Loc : Vertical Diffusion Time Step [s] |
+ ! | |
+ ! | TUkvm(mx,my,mz): Vertical Turbulent Coeffic.(momentum) [m2/s] |
+ ! | TUkvh(mx,my,mz): Vertical Turbulent Coeffic.(heat) [m2/s] |
+ ! | SLuus(mx,my) : Friction Velocity [m/s] |
+ ! | SLuts(mx,my) : Surface Layer Heat Turbulent Flux [mK/s] |
+ ! | SLuqs(mx,my) : Surface Layer Moisture Turbulent Flux [m/s] |
+ ! | qvapSL ! cCA#if(iso) warning, input !
+ ! | uss_HY(mx,my) : Surface Layer Blowing* Turbulent Flux [m/s] |
+ ! | |
+ ! | INPUT / OUTPUT: The Vertical Turbulent Fluxes are included for: |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | 1) The Horizontal x-Wind Component uairDY(mx,my,mz) [m/s] |
+ ! | 2) The Horizontal y-Wind Component vairDY(mx,my,mz) [m/s] |
+ ! | |
+ ! | 3) The Potential Temperature pktaDY(mx,my,mzz) |
+ ! | 4) The Air Specific Humidity qvDY(mx,my,mz) [kg/kg] |
+ ! | |
+ ! | 5) The Ice Crystals Concentration qiHY(mx,my,mz) [kg/kg] |
+ ! | 6) The Ice Crystals Number ccniHY(mx,my,mz) [Nb/m3] |
+ ! | 7) The Cloud Droplets Concentration qwHY(mx,my,mz) [kg/kg] |
+ ! | 8) The Snow Flakes Concentration qsHY(mx,my,mz) [kg/kg] |
+ ! | 9) The Rain Drops Concentration qrHY(mx,my,mz) [kg/kg] |
+ ! | |
+ ! | 10) The Tracer Concentration qxTC(mx,my,mz,ntrac) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_tu
+ use mar_hy
+ use mar_sl
+ use mar_wk
+ use marmagic
+ use trackwater, only: track_water_turabl, jtw, &
+ delta_qv, j_turabl_mix, j_turabl_sbl, delta_qv_tmp
+#if(NH)
+ use mar_nh
+#endif
+#if(TC)
+ use mar_tc
+#endif
+#if(EW)
+ use mar_ew
+#endif
+#if(iso)
+ !cCA todo : add qiHY, qsHY, qwHY, qrHY
+ use mariso, only: wiso, niso, qvDY_iso, &
+ negligible, Rdefault, qvapSL_iso, SLuqs_iso
+#endif
+
+ implicit none
+
+#if(iso)
+ ! Riso : isotopic ratio
+ real :: Riso(niso, mx, my, mz)
+ real :: Riso_uqstar
+ real :: Riso_qvap
+ real, save :: WKxyz4_iso(niso, mx, my, mz)
+ real, save :: WKxyz7_iso(niso, mx, my, mz)
+ real, save :: varin_iso(mx, my, mz)
+ real, save :: varout_iso(mx, my, mz)
+#endif
+
+ logical Q_Impl
+ common / TURabl_lo / Q_Impl
+
+ integer lous, lotu
+ common / TURabl_IN / lous, lotu
+
+ real alpha, beta, ab
+ common / TURabl_re / alpha, beta, ab
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer i1_tua, i2_tua, j1_tua, j2_tua, k1_tua, k2_tua, n, km, kp
+ real uustar, ssvu(mx, my), ssvv(mx, my)
+ real utstar, uqstar, qvap
+ real waterb, ussno, dd_sno
+ real ratio_rfsf, ratio_temp, ratio_prec
+
+ ! +--Parameters
+ ! + ==========
+
+ if(iterun == 0) then
+
+ ! +--Parameters for the Inclusion of the Friction Velocity u*
+ ! + --------------------------------------------------------
+
+ lous = 1
+ lous = 1
+ ! +... lous =1 : SLuus is used
+ ! + lous =0 : SLuus**2 is (partly) replaced by K du / dz
+ ! + CAUTION : do NOT USE lous =0 EXCEPT WHEN VERIFYING THE EKMAN SPIRAL
+
+ ! +--Parameters for the Numerical Scheme of Vertical Turbulent Transport
+ ! + -------------------------------------------------------------------
+
+ Q_Impl = .false.
+ Q_Impl = .true.
+ Q_Impl = .false.
+#if(TC)
+ if(Q_Impl) stop ' #~�@�! BAD Vertical Diffusion of gaseous tracers'
+#endif
+ endif
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--INITIALIZATION
+ ! + ==============
+
+ if(itexpe == 0) then
+ do j = 1, my
+ do i = 1, mx
+ ssvSL(i, j, mz) = max(sqrt(uairDY(i, j, mz) * uairDY(i, j, mz) &
+ + vairDY(i, j, mz) * vairDY(i, j, mz)), epsi)
+ do n = 1, mw
+ cdmSL(i, j, n) = 0.04
+ cdhSL(i, j, n) = 0.04
+ SLuusl(i, j, n) = cdmSL(i, j, n) * ssvSL(i, j, mz)
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ duusSL(i, j) = 0.
+ dutsSL(i, j) = 0.
+ enddo
+ enddo
+ endif
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of Horizontal Momentum
+ ! + =========================================
+
+ ! +--Implicit Surface Scheme
+ ! + -----------------------
+
+ !$OMP PARALLEL do private(i,j,k,i1_tua,i2_tua,j1_tua,j2_tua, &
+ !$OMP k1_tua,k2_tua,n,km,kp,alpha,beta,ab, &
+ !$OMP ratio_rfsf,ratio_temp,ratio_prec, &
+ !$OMP uustar,utstar,uqstar,qvap,waterb,ussno,dd_sno)
+ do j = jp11, my1
+
+ alpha = 0.25 !
+ beta = 1.00 - alpha ! Impliciteness
+ ab = alpha / beta !
+
+ do i = ip11, mx1
+ Kv__SL(i, j) = 0.
+ aeCdSL(i, j) = 0.
+ enddo
+
+ do n = 1, mw
+ do i = ip11, mx1
+ ! aerodynamic conductance
+ aeCdSL(i, j) = aeCdSL(i, j) + cdmSL(i, j, n) * SLuusl(i, j, n) &
+ * Slsrfl(i, j, n)
+ enddo
+ enddo
+ do i = ip11, mx1
+ ! Kv Contrib. in SL
+ Kv__SL(i, j) = &
+ -gravit * aeCdSL(i, j) * beta &
+ * rolvDY(i, j, mz) / (pstDY(i, j) * dsigm1(mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Coefficients : u and v
+ ! + -----------------------------------------
+
+ do i = ip11, mx1
+ ssvu(i, j) = uairDY(i, j, mz) / ssvSL(i, j, mz)
+ ssvv(i, j) = vairDY(i, j, mz) / ssvSL(i, j, mz)
+ enddo
+
+ ! +--Diagonal A
+ ! + ~~~~~~~~~~
+ do i = ip11, mx1
+ WKxyz1(i, j, mz) = Kv__SL(i, j)
+ enddo
+
+ do k = mmz1, 1, -1
+ kp = kp1(k)
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = -gravi2 * beta * romiDY(i, j, k) * &
+ TUkvm(i, j, k) * rolvDY(i, j, k) / &
+ (pstDY2(i, j) * dsigm1(k) * dsig_1(k))
+ enddo
+
+ ! +--Diagonal C
+ ! + ~~~~~~~~~~
+ do i = ip11, mx1
+ WKxyz3(i, j, kp) = WKxyz1(i, j, k) * dsigm1(k) / dsigm1(kp) &
+ * (rolvDY(i, j, kp) / rolvDY(i, j, k))
+ enddo
+
+ enddo
+
+ ! +--A, B, C
+ ! + ~~~~~~~
+ do k = 1, mmz1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * dt_Loc
+ WKxyz3(i, j, k) = WKxyz3(i, j, k) * dt_Loc
+ WKxyz2(i, j, k) = 1.0 - WKxyz3(i, j, k) - WKxyz1(i, j, k)
+ enddo
+ enddo
+
+ ! +--Vertical B.C.
+ ! + ~~~~~~~~~~~~~
+ do i = ip11, mx1
+ WKxyz3(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0 - WKxyz1(i, j, 1)
+
+ WKxyz1(i, j, mz) = WKxyz1(i, j, mz) * dt_Loc
+ WKxyz3(i, j, mz) = WKxyz3(i, j, mz) * dt_Loc
+ WKxyz2(i, j, mz) = 1.0 - WKxyz3(i, j, mz) - WKxyz1(i, j, mz)
+ enddo
+
+ ! +--Second Member of the Tridiagonal System - u
+ ! + -------------------------------------------
+
+ kp = kp1(1)
+ do i = ip11, mx1
+ WKxyz4(i, j, 1) = WKxyz1(i, j, 1) &
+ * ab * (uairDY(i, j, 1) - uairDY(i, j, kp))
+ enddo
+
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (uairDY(i, j, k) - uairDY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (uairDY(i, j, km) - uairDY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+
+ uustar = SLuus(i, j) * SLuus(i, j)
+
+ ! +--Implicit Surface Scheme
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ ! explicit
+ uustar = 0.1 * duusSL(i, j)
+
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) * ab * uairDY(i, j, mz) &
+ - WKxyz3(i, j, mz) * ab * (uairDY(i, j, mmz1) - uairDY(i, j, mz)) &
+ - lous * alpha * gravit * romiDY(i, j, mz) * dt_Loc &
+ * uustar * ssvu(i, j) / (pstDY(i, j) * dsigm1(mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - u
+ ! + --------------------------------
+
+ k1_tua = 1
+ do k = k1_tua, mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + uairDY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mz
+ do i = ip11, mx1
+ uairDY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--Second Member of the Tridiagonal System - v
+ ! + -------------------------------------------
+
+ kp = kp1(1)
+ do i = ip11, mx1
+ WKxyz4(i, j, 1) = WKxyz1(i, j, 1) &
+ * ab * (vairDY(i, j, 1) - vairDY(i, j, kp))
+ enddo
+
+ do k = kp1(1), mmz1
+ km = km1(k)
+ kp = kp1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (vairDY(i, j, k) - vairDY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (vairDY(i, j, km) - vairDY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ uustar = SLuus(i, j) * SLuus(i, j)
+ ! +--Implicit Surface Scheme
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ uustar = 0.1 * duusSL(i, j) ! explicit
+ duusSL(i, j) = 0.9 * duusSL(i, j) !
+
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) * ab * vairDY(i, j, mz) &
+ - WKxyz3(i, j, mz) * ab * (vairDY(i, j, mmz1) - vairDY(i, j, mz)) &
+ - lous * alpha * gravit * romiDY(i, j, mz) * dt_Loc &
+ * uustar * ssvv(i, j) / (pstDY(i, j) * dsigm1(mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - v
+ ! + --------------------------------
+
+ k1_tua = 1
+ do k = k1_tua, mz
+ ! do j= jp11,my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + vairDY(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do i = ip11, mx1
+ uustar = aeCdSL(i, j) * ((alpha * WKxy1(i, j) + beta * uairDY(i, j, mz)) * ssvu(i, j) &
+ + (alpha * vairDY(i, j, mz) + beta * WKxyz7(i, j, mz)) * ssvv(i, j))
+ duusSL(i, j) = duusSL(i, j) + SLuus(i, j) * SLuus(i, j) - uustar
+ enddo
+
+ do k = 1, mz
+ do i = ip11, mx1
+ vairDY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of Heat and Water Vapor
+ ! + ==========================================
+
+ ! +--Implicit Surface Scheme
+ ! + -----------------------
+
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ Kv__SL(i, j) = 0.
+ aeCdSL(i, j) = 0.
+ enddo
+ ! end do
+
+ do n = 1, mw
+ do i = ip11, mx1
+ ! aerodynamic conductance
+ aeCdSL(i, j) = aeCdSL(i, j) + cdhSL(i, j, n) * SLuusl(i, j, n) &
+ * Slsrfl(i, j, n)
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ ! Kv Contrib. above SL
+ ! + Kv__SL(i,j) = &
+ ! + -gravi2*romiDY(i,j,mz) * TUkvh(i,j,mz) *beta &
+ ! + *rolvDY(i,j,mz)/(pstDY2(i,j)* dsigm1(mz)*dsig_1(mz))
+ ! Kv Contrib. in SL
+ Kv__SL(i, j) = &
+ -gravit * aeCdSL(i, j) * beta &
+ * rolvDY(i, j, mz) / (pstDY(i, j) * dsigm1(mz))
+ enddo
+
+ ! +--Tridiag. Matrix Coeff. : pktaDY, qvDY
+ ! + ---------------------------------------
+
+ ! +--Diagonal A
+ ! + ~~~~~~~~~~
+ k = mz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = Kv__SL(i, j)
+ enddo
+
+ do k = mmz1, 1, -1
+ do i = ip11, mx1
+ ! TUkvh : Vertical Turbulent Coeffic. (heat) [m2/s]
+ ! WKxyz1 = - g^2 rho^2 * TUkvh / dp^2 [dp/dz = rho g => rho g / dp = 1/dz]
+ ! WKxyz1 in [m2 s-1] * [m-2] -> multiplied by dt hereafter
+ WKxyz1(i, j, k) = -gravi2 * beta * &
+ romiDY(i, j, k) * TUkvh(i, j, k) * rolvDY(i, j, k) / &
+ (pstDY2(i, j) * dsigm1(k) * dsig_1(k))
+ enddo
+ enddo
+
+ ! +--Diagonal C
+ ! + ~~~~~~~~~~
+ do k = mz, 1, -1
+ kp = kp1(k)
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz3(i, j, kp) = WKxyz1(i, j, k) * dsigm1(k) / dsigm1(kp) &
+ / rolvDY(i, j, k) * rolvDY(i, j, kp)
+ enddo
+ ! end do
+ enddo
+
+ ! +--A, B, C
+ ! + ~~~~~~~
+ do k = 1, mz
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * dt_Loc
+ WKxyz3(i, j, k) = WKxyz3(i, j, k) * dt_Loc
+ WKxyz2(i, j, k) = 1.0 - WKxyz3(i, j, k) - WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Vertical B.C.
+ ! + ~~~~~~~~~~~~~
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz3(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0 - WKxyz1(i, j, 1)
+ enddo
+ ! end do
+
+ ! +--SBC of the Tridiagonal System - pktaDY
+ ! + --------------------------------------
+
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ utstar = SLuts(i, j)
+
+ ! +--Implicit Surface Scheme
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ ! explicit
+ utstar = 0.1 * dutsSL(i, j)
+ ! set := 0
+ dutsSL(i, j) = 0.9 * dutsSL(i, j)
+ !
+ ! partly explicit
+ WKxyz4(i, j, mz) = WKxyz1(i, j, mz) &
+ * (ab * pktaDY(i, j, mz) - pktaSL(i, j) / beta) &
+ - WKxyz3(i, j, mz) * ab * (pktaDY(i, j, mmz1) - pktaDY(i, j, mz)) &
+ ! u*T* all explicit
+ - gravit * dt_Loc * rolvDY(i, j, mz) &
+ * utstar / (pcap * pstDY(i, j) * dsigm1(mz))
+ enddo
+ ! end do
+
+ ! +--Second Member of the Tridiagonal System - pktaDY
+ ! + ------------------------------------------------
+
+ do k = kp1(1), mmz1
+ km = km1(k)
+ kp = kp1(k)
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (pktaDY(i, j, k) - pktaDY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (pktaDY(i, j, km) - pktaDY(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ ! +--UBC of the Tridiagonal System - pktaDY
+ ! + ------------------------------------------------
+
+ kp = kp1(1)
+ do i = ip11, mx1
+ WKxyz4(i, j, 1) = &
+ WKxyz1(i, j, 1) * ab * (pktaDY(i, j, 1) - pktaDY(i, j, kp))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - pktaDY
+ ! + -------------------------------------
+
+ k1_tua = 1
+ do k = k1_tua, mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + pktaDY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do i = ip11, mx1
+ utstar = aeCdSL(i, j) * (alpha * pktaDY(i, j, mz) + beta * WKxyz7(i, j, mz) &
+ - pktaDY(i, j, mzz)) &
+ * pcap
+ dutsSL(i, j) = dutsSL(i, j) + SLuts(i, j) - utstar
+ enddo
+
+ do k = 1, mz
+ do i = ip11, mx1
+ pktaDY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of Moisture
+ ! + ==============================
+
+ ! +--Tridiag. Matrix Coeff. : qvDY
+ ! + -----------------------------
+
+ ! +--Diagonal A
+ ! + ~~~~~~~~~~
+ k = mz
+ do i = ip11, mx1
+ Kv__SL(i, j) = 0.
+ WKxyz1(i, j, k) = Kv__SL(i, j)
+ ! +--Diagonal B
+ ! + ~~~~~~~~~~
+ WKxyz2(i, j, k) = 1.00 - WKxyz3(i, j, k)
+ enddo
+
+ ! +--UBC of the Tridiagonal System - qvDY
+ ! + ------------------------------------
+#if(iso)
+ ! todo : check if Riso is more pertinent that qiso
+ ! initialize isotopic ratios
+ do k = 1, mz
+ do i = ip11, mx1
+ if(qvDY(i, j, k) > negligible) then
+ do wiso = 1, niso
+ Riso(wiso, i, j, k) = qvDY_iso(wiso, i, j, k) / qvDY(i, j, k)
+ enddo
+ else
+ do wiso = 1, niso
+ Riso(wiso, i, j, k) = Rdefault(wiso)
+ enddo
+ endif
+ enddo
+ enddo
+#endif
+
+ kp = kp1(1)
+ do i = ip11, mx1
+ WKxyz4(i, j, 1) = WKxyz1(i, j, 1) * ab * (qvDY(i, j, 1) - qvDY(i, j, kp))
+ if(track_water_turabl) then
+ ! Compute the contribution of qv only, without surface sublimation
+ WTxyz4(i, j, 1) = WKxyz4(i, j, 1)
+ end if
+#if(iso)
+ do wiso = 1, niso
+ WKxyz4_iso(wiso, i, j, 1) = WKxyz1(i, j, 1) * ab * (Riso(wiso, i, j, 1) - Riso(wiso, i, j, kp))
+ enddo
+#endif
+ enddo
+
+ ! +--Second Member of the Tridiagonal System - qvDY
+ ! + ----------------------------------------------
+
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz1(i, j, k) * ab * (qvDY(i, j, k) - qvDY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (qvDY(i, j, km) - qvDY(i, j, k))
+ if(track_water_turabl) then
+ ! Compute the contribution of qv only, without surface sublimation
+ WTxyz4(i, j, k) = WKxyz4(i, j, k)
+ end if
+#if(iso)
+ do wiso = 1, niso
+ WKxyz4_iso(wiso, i, j, k) = WKxyz1(i, j, k) * ab &
+ * (Riso(wiso, i, j, k) - Riso(wiso, i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (Riso(wiso, i, j, km) - Riso(wiso, i, j, k))
+ enddo
+#endif
+ enddo
+ ! end do
+ enddo
+
+ ! +--SBC of the Tridiagonal System - qvDY
+ ! + ------------------------------------
+
+ ! do j=jp11,my1
+ do i = ip11, mx1
+
+ ! commented because not used
+ !cCAiso ! +--Implicit Surface Scheme
+ !cCAiso ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ !cCAiso qvap = qvDY(i, j, mz) - SLuqs(i, j) / aeCdSL(i, j)
+ !cCAiso
+ !cCAiso ! uqstar is replaced by aeCdSL*(qvDY-qvapSL), set := 0
+ !cCAiso uqstar = 0. ! explicit
+
+ ! +--Explicit Surface Scheme
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~
+ qvap = qvapSL(i, j)
+ ! uqstar = SLuqs is the Moisture Turbulent Flux
+ ! uqstar * rhAir * dt__SV -> evaporation flux, in kg m-2 (= kg kg-1 m s-1 kg m-3 s)
+ ! uqstar * rhAir * dt__SV * g / dp -> g/dp = rho/dz
+ uqstar = SLuqs(i, j)
+
+ ! partly explicit
+ WKxyz4(i, j, mz) = WKxyz1(i, j, mz) * (ab * qvDY(i, j, mz) - qvap / beta) &
+ - WKxyz3(i, j, mz) * ab * (qvDY(i, j, mmz1) - qvDY(i, j, mz)) &
+ ! u*q* all explicit
+ - gravit * dt_Loc * rolvDY(i, j, mz) * uqstar / (pstDY(i, j) * dsigm1(mz))
+ if(track_water_turabl) then
+ ! Compute the contribution of qv only, without surface sublimation
+ WTxyz4(i, j, mz) = WKxyz1(i, j, mz) * (ab * qvDY(i, j, mz) - qvap / beta) &
+ - WKxyz3(i, j, mz) * ab * (qvDY(i, j, mmz1) - qvDY(i, j, mz))
+ end if
+#if(iso)
+ do wiso = 1, niso
+ if(qvap > negligible) then
+ Riso_qvap = qvapSL_iso(wiso, i, j) / qvap
+ else
+ Riso_qvap = Rdefault(wiso)
+ endif
+ if(uqstar > negligible) then
+ Riso_uqstar = SLuqs_iso(wiso, i, j) / uqstar
+ else
+ Riso_uqstar = Rdefault(wiso)
+ endif
+ WKxyz4_iso(wiso, i, j, mz) = WKxyz1(i, j, mz) * (ab * Riso(wiso, i, j, mz) - Riso_qvap / beta) &
+ - WKxyz3(i, j, mz) * ab * (Riso(wiso, i, j, mmz1) - Riso(wiso, i, j, mz)) &
+ ! u*q* all explicit g dt rho uq* / dp | dt rho uq* = [kg m-2] | dt rho uq* g / dp = [kg m-2] / [rho dz]
+ ! convertion of uqstar into qsurf in kg/kg
+ ! - gravit * dt_Loc * rolvDY(i, j, mz) * uqstar / (pstDY(i, j) * dsigm1(mz))
+ - Riso_uqstar
+ enddo
+#endif
+ enddo
+ ! end do
+
+ ! +--Tridiagonal Matrix Inversion - qvDY
+ ! + -----------------------------------
+
+ k1_tua = 1
+ do k = k1_tua, mz
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qvDY(i, j, k)
+ if(track_water_turabl) then
+ ! Compute the contribution of qv only, without surface sublimation
+ WTxyz4(i, j, k) = WTxyz4(i, j, k) + qvDY(i, j, k)
+ end if
+#if(iso)
+ do wiso = 1, niso
+ WKxyz4_iso(wiso, i, j, k) = WKxyz4_iso(wiso, i, j, k) + Riso(wiso, i, j, k)
+ enddo
+#endif
+ enddo
+ ! end do
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+ if(track_water_turabl) then
+ ! Compute the contribution of qv only, without surface sublimation
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WTxyz4, WTxyz7)
+ end if
+#if(iso)
+ do wiso = 1, niso
+ do i = 1, mx
+ varin_iso(i, j, :) = WKxyz4_iso(wiso, i, j, :)
+ enddo
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, varin_iso, varout_iso)
+ do i = 1, mx
+ WKxyz7_iso(wiso, i, j, :) = varout_iso(i, j, :)
+ enddo
+ enddo
+#endif
+ do k = 1, mz
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ if(track_water_turabl) then
+ ! delta_qv_mix = delta_qv without sublimation
+ delta_qv(i, j, k, j_turabl_mix) = delta_qv(i, j, k, j_turabl_mix) + WTxyz7(i, j, k) - qvDY(i, j, k)
+ ! delta_qv_tot = WKxyz7(i, j, k) - qvDY(i, j, k)
+ ! subl = delta_qv_tot - delta_qv_mix
+ delta_qv(i, j, k, j_turabl_sbl) = delta_qv(i, j, k, j_turabl_sbl) + WKxyz7(i, j, k) - WTxyz7(i, j, k)
+ end if
+#if(iso)
+ do wiso = 1, niso
+ qvDY_iso(wiso, i, j, k) = WKxyz7_iso(wiso, i, j, k) * qvDY(i, j, k)
+ enddo
+#endif
+ qvDY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+#if(TC)
+ ! +--Vertical Diffusion of gazeous Tracers
+ ! + =====================================
+ if(dt_ODE == dtDiff) then
+ ! +--Second Member of the Tridiagonal System - qxTC
+ ! + ----------------------------------------------
+ ! CAUTION: defines nterr as the Nb of terregenous aerosols (usually 0 .OR. 1)
+ do n = nterr + 1, ntrac
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = qxTC(i, j, 1, n)
+ enddo
+ enddo
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (qxTC(i, j, k, n) - qxTC(i, j, kp, n)) &
+ - WKxyz3(i, j, k) * ab * (qxTC(i, j, km, n) - qxTC(i, j, k, n))
+ enddo
+ enddo
+ enddo
+ if(.not. BloMod) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ uqTC(i, j, n) = -cdhSL(i, j, 1) * SLuusl(i, j, 1) &
+ * (qsTC(i, j, n) - qxTC(i, j, mz, n))
+ enddo
+ enddo
+ endif
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, mz) = WKxyz1(i, j, mz) &
+ * (ab * qxTC(i, j, mz, n) - qsTC(i, j, n) / beta) &
+ - WKxyz3(i, j, mz) * ab * (qxTC(i, j, mmz1, n) - qxTC(i, j, mz, n)) &
+ + (gravit * dt_Loc &
+ * rolvDY(i, j, mz) / (pstDY(i, j) * (sigmid(mz) - 1.0d+0))) &
+ * uqTC(i, j, n)
+ enddo
+ enddo
+ ! +--Tridiagonal Matrix Inversion - qxTC
+ ! + -----------------------------------
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qxTC(i, j, k, n)
+ enddo
+ enddo
+ enddo
+ k1_tua = 1
+ k2_tua = mz
+ ! + ************
+ call MARgz_2mx1y1(k1_tua, k2_tua)
+ ! + ************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qxTC(i, j, k, n) = WKxyz7(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+
+#if(EW)
+ ! +--Atmospheric Water Budget
+ ! + ========================
+ do j = jp11, my1
+ do i = ip11, mx1
+ wat0EW(i, j) = 0.0
+ do k = 1, mz
+ wat0EW(i, j) = wat0EW(i, j) &
+ + (qvDY(i, j, k) &
+ + qwHY(i, j, k) + qrHY(i, j, k) &
+ + qiHY(i, j, k) + qsHY(i, j, k)) * dsigm1(k)
+ enddo
+ wat0EW(i, j) = wat0EW(i, j) * pstDY(i, j) * grvinv
+ enddo
+ enddo
+#endif
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of Hydrometeors and non gazeous Tracers
+ ! + ==========================================================
+
+ ! +--Parameters for the Numerical Scheme of Vertical Turbulent Transport
+ ! + -------------------------------------------------------------------
+
+ ! alpha : Expliciteness = 0 (positive definite)
+ alpha = 0.00
+ ! beta : Impliciteness
+ beta = 1.00 - alpha
+ ab = alpha / beta
+ !cCA todo : add qiHY, qsHY, qwHY, qrHY
+ ! +--Tridiagonal Matrix Coefficients: qiHY, ccniHY, qwHY, qrHY
+ ! + (Turbulent Diffusion Coefficient X 3: Bintanja, 2000, BLM) --+
+ ! + ----------------------------------------------------------- V
+
+ ! +--Diagonal A
+ ! + ~~~~~~~~~~
+ do k = mz, 1, -1
+ kp = kp1(k)
+
+ do i = ip11, mx1
+ WKxyz8(i, j, k) = TUkvh(i, j, k) * r_Turb
+ enddo
+
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = -gravi2 * beta * romiDY(i, j, k) * WKxyz8(i, j, k) &
+ * rolvDY(i, j, k) / (pstDY2(i, j) * dsigm1(k) * dsig_1(k))
+ enddo
+
+ ! +--Diagonal C
+ ! + ~~~~~~~~~~
+ do i = ip11, mx1
+ WKxyz3(i, j, kp) = WKxyz1(i, j, k) * dsigm1(k) / dsigm1(kp) &
+ / rolvDY(i, j, k) * rolvDY(i, j, kp)
+ enddo
+
+ enddo
+
+ ! +--A, B, C
+ ! + ~~~~~~~
+ do k = 1, mz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * dt_Loc
+ WKxyz3(i, j, k) = WKxyz3(i, j, k) * dt_Loc
+ WKxyz2(i, j, k) = 1.0 - WKxyz3(i, j, k) - WKxyz1(i, j, k)
+ enddo
+ enddo
+
+ ! +--Vertical B.C.
+ ! + ~~~~~~~~~~~~~
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz3(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0 - WKxyz1(i, j, 1)
+ enddo
+ ! end do
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--BEGIN Cloud Microphysics (qiHY, ccniHY, qwHY, qrHY)
+ ! + ===================================================
+
+ if(micphy) then
+ ! +--Vertical Diffusion of Ice Crystals
+ ! + ==================================
+
+ ! +--Second Member of the Tridiagonal System - qiHY
+ ! + ----------------------------------------------
+
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = qiHY(i, j, 1)
+ enddo
+
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (qiHY(i, j, k) - qiHY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (qiHY(i, j, km) - qiHY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) * ab * (qiHY(i, j, mz) - zero) &
+ - WKxyz3(i, j, mz) * ab * (qiHY(i, j, mmz1) - qiHY(i, j, mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - qiHY
+ ! + -----------------------------------
+
+ do k = kp1(1), mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qiHY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mz
+ do i = ip11, mx1
+ qiHY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--Second Member of the Tridiagonal System - ccniHY
+ ! + ------------------------------------------------
+
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = ccniHY(i, j, 1)
+ enddo
+
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (ccniHY(i, j, k) - ccniHY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (ccniHY(i, j, km) - ccniHY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) * ab * (ccniHY(i, j, mz) - zero) &
+ - WKxyz3(i, j, mz) * ab * (ccniHY(i, j, mmz1) - ccniHY(i, j, mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - ccniHY
+ ! + -------------------------------------
+
+ do k = kp1(1), mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + ccniHY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mz
+ do i = ip11, mx1
+ ccniHY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--Precipitation
+ ! + -------------
+
+ do i = ip11, mx1
+ dd_sno = dt_Loc * rolvDY(i, j, mz) &
+ * WKxyz8(i, j, mz) * qiHY(i, j, mz) &
+ / (gplvDY(i, j, mz) * grvinv - sh(i, j))
+ crysHY(i, j) = crysHY(i, j) + dd_sno
+ snohSL(i, j) = snohSL(i, j) + dd_sno
+ enddo
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of Cloud Droplets
+ ! + ====================================
+
+ ! +--Second Member of the Tridiagonal System - qwHY
+ ! + ----------------------------------------------
+
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = qwHY(i, j, 1)
+ enddo
+
+ do k = kp1(1), mmz1
+ km = km1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (qwHY(i, j, k) - qwHY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (qwHY(i, j, km) - qwHY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) * ab * (qwHY(i, j, mz) - zero) &
+ - WKxyz3(i, j, mz) * ab * (qwHY(i, j, mmz1) - qwHY(i, j, mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - qwHY
+ ! + -----------------------------------
+
+ do k = kp1(1), mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qwHY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mz
+ do i = ip11, mx1
+ qwHY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--Precipitation
+ ! + -------------
+ do i = ip11, mx1
+ ratio_temp = (tairDY(i, j, mz - 1) + tairDY(i, j, mz - 2) &
+ + tairDY(i, j, mz - 3) + tairDY(i, j, mz - 4)) / 4.
+
+ ratio_prec = dt_Loc * rolvDY(i, j, mz) &
+ * WKxyz8(i, j, mz) * qwHY(i, j, mz) &
+ / (gplvDY(i, j, mz) * grvinv - sh(i, j))
+
+ ratio_rfsf = max(0., min(1.,(ratio_temp - rain_snow_limit) / 2.))
+
+ rainHY(i, j) = rainHY(i, j) + ratio_prec * ratio_rfsf
+ snowHY(i, j) = snowHY(i, j) + ratio_prec * (1.-ratio_rfsf)
+ enddo
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of Rain Drops
+ ! + ================================
+
+ ! +--Second Member of the Tridiagonal System - qrHY
+ ! + ----------------------------------------------
+
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = qrHY(i, j, 1)
+ enddo
+
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (qrHY(i, j, k) - qrHY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (qrHY(i, j, km) - qrHY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) * ab * (qrHY(i, j, mz) - zero) &
+ - WKxyz3(i, j, mz) * ab * (qrHY(i, j, mmz1) - qrHY(i, j, mz))
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - qrHY
+ ! + -----------------------------------
+
+ do k = kp1(1), mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qrHY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mz
+ do i = ip11, mx1
+ qrHY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--Precipitation
+ ! + -------------
+
+ do i = ip11, mx1
+ ratio_temp = (tairDY(i, j, mz - 1) + tairDY(i, j, mz - 2) &
+ + tairDY(i, j, mz - 3) + tairDY(i, j, mz - 4)) / 4.
+ ratio_prec = dt_Loc * rolvDY(i, j, mz) &
+ * WKxyz8(i, j, mz) * qrHY(i, j, mz) &
+ / (gplvDY(i, j, mz) * grvinv - sh(i, j))
+
+ ratio_rfsf = max(0., min(1.,(ratio_temp - rain_snow_limit) / 2.))
+
+ rainHY(i, j) = rainHY(i, j) + ratio_prec * ratio_rfsf
+ snowHY(i, j) = snowHY(i, j) + ratio_prec * (1.-ratio_rfsf)
+ enddo
+
+ ! +--END Cloud Microphysics (qiHY, ccniHY, qwHY, qrHY)
+ ! + ===================================================
+
+ endif
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--Vertical Diffusion of (Terrigeneous) Hydrometeors and Tracers
+ ! + =============================================================
+
+ ! +--Tridiagonal Matrix Coefficients: Modifications for qsHY, qxTC
+ ! + -------------------------------------------------------------
+
+ ! +--Diagonal A
+ ! + ~~~~~~~~~~
+ k = mz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = 0.
+ enddo
+
+ ! +--A, B, C
+ ! + ~~~~~~~
+ k = mz
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * dt_Loc
+ WKxyz2(i, j, k) = 1.0 - WKxyz3(i, j, k) - WKxyz1(i, j, k)
+ enddo
+
+ ! +-------------------------------------------------------------------------
+
+ ! +--BEGIN Cloud Microphysics (qsHY)
+ ! + ===============================
+
+ if(micphy) then
+
+ ! +--Vertical Diffusion of Snow Flakes
+ ! + =================================
+
+ ! +--Second Member of the Tridiagonal System - qsHY
+ ! + ----------------------------------------------
+
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = qsHY(i, j, 1)
+ enddo
+
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (qsHY(i, j, k) - qsHY(i, j, kp)) &
+ - WKxyz3(i, j, k) * ab * (qsHY(i, j, km) - qsHY(i, j, k))
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ ussno = uss_HY(i, j)
+ WKxyz4(i, j, mz) = &
+ WKxyz1(i, j, mz) &
+ * (ab * qsHY(i, j, mz) - qsrfHY(i, j) / beta) &
+ - WKxyz3(i, j, mz) * ab * (qsHY(i, j, mmz1) - qsHY(i, j, mz)) &
+ + (gravit * dt_Loc * rolvDY(i, j, mz) &
+ / (pstDY(i, j) * (sigmid(mz) - 1.0))) &
+ * ussno
+ enddo
+
+ ! +--Tridiagonal Matrix Inversion - qsHY
+ ! + -----------------------------------
+
+ do k = kp1(1), mz
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qsHY(i, j, k)
+ enddo
+ enddo
+
+ k1_tua = 1
+ k2_tua = mz
+
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mz
+ do i = ip11, mx1
+ qsHY(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ enddo
+
+ ! +--END Cloud Microphysics (qsHY)
+ ! + ===============================
+
+ endif
+
+ ! +-------------------------------------------------------------------------
+
+#if(TC)
+ ! +--Vertical Diffusion of non gazeous Tracers
+ ! + =========================================
+ if(dt_ODE == dtDiff .and. nterr > 0) then
+ ! +--Second Member of the Tridiagonal System - qxTC
+ ! + ----------------------------------------------
+ do n = 1, nterr
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = qxTC(i, j, 1, n)
+ enddo
+ enddo
+ do k = kp1(1), mmz1
+ kp = kp1(k)
+ km = km1(k)
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (qxTC(i, j, k, n) - qxTC(i, j, kp, n)) &
+ - WKxyz3(i, j, k) * ab * (qxTC(i, j, km, n) - qxTC(i, j, k, n))
+ enddo
+ enddo
+ enddo
+ if(.not. BloMod) then
+ do j = jp11, my1
+ do i = ip11, mx1
+ uqTC(i, j, n) = -cdhSL(i, j, 1) * SLuusl(i, j, 1) &
+ * (qsTC(i, j, n) - qxTC(i, j, mz, n))
+ enddo
+ enddo
+ endif
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, mz) = WKxyz1(i, j, mz) &
+ * (ab * qxTC(i, j, mz, n) - qsTC(i, j, n) / beta) &
+ - WKxyz3(i, j, mz) * ab * (qxTC(i, j, mmz1, n) - qxTC(i, j, mz, n)) &
+ + (gravit * dt_Loc &
+ * rolvDY(i, j, mz) / (pstDY(i, j) * (sigmid(mz) - 1.0d+0))) &
+ * uqTC(i, j, n)
+ enddo
+ enddo
+ ! +--Tridiagonal Matrix Inversion - qxTC
+ ! + -----------------------------------
+ do k = kp1(1), mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + qxTC(i, j, k, n)
+ enddo
+ enddo
+ enddo
+ k1_tua = 1
+ k2_tua = mz
+ ! + ************
+ call MARgz_2mx1y1_mp(k1_tua, k2_tua, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qxTC(i, j, k, n) = WKxyz7(i, j, k)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+
+#if(EW)
+ ! +--Atmospheric Water Budget
+ ! + ========================
+ do i = ip11, mx1
+ do j = jp11, my1
+ wat1EW(i, j) = 0.00
+ do k = 1, mz
+ wat1EW(i, j) = wat1EW(i, j) &
+ + (qvDY(i, j, k) &
+ + qwHY(i, j, k) + qrHY(i, j, k) &
+ + qiHY(i, j, k) + qsHY(i, j, k)) * dsigm1(k)
+ enddo
+ wat1EW(i, j) = wat1EW(i, j) * pstDY(i, j) * grvinv
+ watfEW(i, j) = -(uss_HY(i, j) + SLuqs(i, j)) &
+ * dt_Loc * rolvDY(i, j, mz)
+ enddo
+ enddo
+ ! +--Atmospheric Water Budget: Output
+ ! + ================================
+ ! +
+ waterb = wat1EW(imez, jmez) &
+ - wat0EW(imez, jmez) - watfEW(imez, jmez)
+ write(6, 606) jdaMAR, jhaMAR, jmmMAR, &
+ 1.d3 * wat0EW(imez, jmez), 1.d3 * wat1EW(imez, jmez), &
+ 1.d3 * watfEW(imez, jmez), &
+ 1.d3 * waterb
+606 format(3i3, ' Before vDif: ', 12x, ' W0 = ', f9.6, &
+ /, 9x, ' After vDif: ', 12x, ' W1 = ', f9.6, &
+ ' W Flux =', f9.6, &
+ ' Div(W) =', e9.3)
+#endif
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ do k = 1, mz
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = 0.00
+ WKxyz2(i, j, k) = 0.00
+ WKxyz3(i, j, k) = 0.00
+ WKxyz4(i, j, k) = 0.00
+ WKxyz5(i, j, k) = 0.00
+ WKxyz6(i, j, k) = 0.00
+ WKxyz7(i, j, k) = 0.00
+ enddo
+ ! end do
+ enddo
+
+ ! do j=jp11,my1
+ do i = ip11, mx1
+ WKxy1(i, j) = 0.00
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+endsubroutine TURabl
diff --git a/MAR/code_mar/turhor_dyn.f90 b/MAR/code_mar/turhor_dyn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..171c88abfc68fa4ebcd92e0b921cc5339e71012c
--- /dev/null
+++ b/MAR/code_mar/turhor_dyn.f90
@@ -0,0 +1,697 @@
+#include "MAR_pp.def"
+subroutine turhor_dyn(dtHDif)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE HORIZONTAL Sat 08-09-2017 MAR |
+ ! | subroutine turhor_dyn computes Horizontal Diffusion |
+ ! | and Correction Terms |
+ ! | using an Explicit Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: dt_Loc: Time Step between two CaLLs of Horiz. Diffusion Routine |
+ ! | ^^^^^ dtHDif: Time Step between two run of Horiz. Diffusion Scheme |
+ ! | (dt_Loc = n X dtHDif, n = 1,2,...) |
+ ! | micphy: Cloud Microphysical Scheme Switch |
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ TUkhx(mx,my,mz): Horizontal Diffusion Coefficient (x-Direction) |
+ ! | TUkhy(mx,my,mz): Horizontal Diffusion Coefficient (y-Direction) |
+ ! | |
+ ! | INPUT / OUTPUT |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | The Horizontal Diffusion and Correction Terms are included for : |
+ ! | 1) The Horizontal x-Wind Component uairDY(mx,my,mz) [m/s] |
+ ! | 2) The Horizontal y-Wind Component vairDY(mx,my,mz) [m/s] |
+ ! | |
+ ! | #NH 3) The Vertical z-Wind Component wairNH(mx,my,mz) [m/s] |
+ ! | |
+ ! | 4) The Potential Temperature pktaDY(mx,my,mzz) |
+ ! | 5) The Air Specific Humidity qvDY(mx,my,mz) [kg/kg] |
+ ! | |
+ ! | #HY 6) The Ice Crystals Concentration qiHY(mx,my,mz) [kg/kg] |
+ ! | 7) The Ice Crystals Number ccniHY(mx,my,mz) [Nb/m3] |
+ ! | 8) The Cloud Droplets Concentration qwHY(mx,my,mz) [kg/kg] |
+ ! | 9) The Snow Flakes Concentration qsHY(mx,my,mz) [kg/kg] |
+ ! | 10) The Rain Drops Concentration qrHY(mx,my,mz) [kg/kg] |
+ ! | |
+ ! | #TC 11) The Tracer Concentration qxTC(mx,my,mz,ntrac) |
+ ! | |
+ ! | REMARK: |
+ ! | ^^^^^^^ |
+ ! | !. `Standard' Horizontal Diffusion is performed on Sigma Surfaces |
+ ! | !. Smagorinski Relation (see Tag et al. 1979, JAM 18, 1429--1441) |
+ ! | !. CAUTION: Horizontal Diffusion is switched on with turhor = .true. |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_tu
+ use mar_fi
+ use mar_hy
+ use mar_wk
+#if(TC)
+ use mar_tc
+#endif
+#if(NH)
+ use mar_nh
+#endif
+#if(iso)
+ use mariso, only: niso, wiso, qvDY_iso, Rdefault, negligible
+#endif
+
+ implicit none
+
+#if(iso)
+ logical :: is_iso
+ real :: WKxyz1_iso(niso, mx, my, mz)
+ real :: WKxyz5_iso(niso, mx, my, mz)
+#endif
+
+ real dtHDif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer nntrac, ntDifH, iter, n_kq, ivar, itrac
+ real akhsta, akhloc, cflakh, dx2inv, gdx2
+ real facxx, facxy, facyy, alph2, beta2, akhm2, alph22, beta22
+
+ real vartop(mx, my), varbot(mx, my)
+
+ ! +--DATA
+ ! + ====
+
+ data nntrac/0/
+#if(TC)
+ nntrac = ntrac
+#endif
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+#if(iso)
+ ! initialize working variable for isotopes
+ do wiso = 1, niso
+ WKxyz1_iso(wiso, i, j, k) = 0.
+ WKxyz5_iso(wiso, i, j, k) = 0.
+ enddo
+#endif
+ enddo
+ enddo
+ enddo
+
+#if(iso)
+ is_iso = .false.
+#endif
+
+ ! +--Update of Local Variables and
+ ! + Mesh Averaged Horizontal Diffusion Coefficient akhm
+ ! + =============================================================
+
+ akhsta = 0.0
+ do k = 1, mz
+
+ do i = ip11, mx1
+ do j = jp11, my1
+ WKxyz1(i, j, k) = FIkhmn + 0.25 * (TUkhx(i, j, k) + TUkhx(im1(i), j, k))
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) + 0.25 * (TUkhy(i, j, k) + TUkhy(i, jm1(j), k))
+ akhsta = max(WKxyz1(i, j, k), akhsta)
+ enddo
+ enddo
+
+ enddo
+
+ ! +--Local Time step
+ ! + ===============
+
+ cflakh = dt_Loc * akhsta / dx / dx
+ ntDifH = 3 * cflakh
+ ntDifH = max(iun, ntDifH)
+ dtHDif = dt_Loc / ntDifH
+
+ ! +--Update of Local Coefficients
+ ! + ============================
+
+ dx2inv = 1.0 / dx / dx
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = dx2inv / pstDY(i, j)
+ WKxy4(i, j) = 1.0 / (pstDY(i, j) * pstDY(i, j))
+ enddo
+ enddo
+
+ do i = 1, mx1
+ do j = 1, my
+ WKxy1(i, j) = 0.5 * (pstDY(i, j) + pstDY(ip1(i), j))
+ enddo
+ enddo
+
+ if(mmy > 1) then
+ do j = 1, my1
+ do i = 1, mx
+ WKxy2(i, j) = 0.5 * (pstDY(i, j) + pstDY(i, jp1(j)))
+ enddo
+ enddo
+ endif
+
+ gdx2 = 0.5 * gravit / dx
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz3(i, j, k) = gdx2 / (pstDY(i, j) * dsig_2(k))
+ enddo
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy4(i, j) = 0.0
+ enddo
+ enddo
+
+ ! +--Global Variables Loop
+ ! + =====================
+
+ n_kq = 5 ! Nombre de variables à diffuser: u,v,(w),T,q
+
+ !$OMP PARALLEL DO private (i,j,k) firstprivate(iter,ivar)
+ do k = 1, mz
+ do iter = 1, ntDifH
+ do ivar = 1, n_kq
+#if(TC)
+ if(ivar > 10) go to 341
+#endif
+
+ go to(331, 332, 333, 334, 335, 336, 337, 338, 339, 340) ivar
+
+ ! +--u Wind Speed Component
+ ! + ----------------------
+
+331 continue
+
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = uairDY(i, j, k)
+ enddo
+ enddo
+
+ go to 330
+
+ ! +--v Wind Speed Component
+ ! + ----------------------
+
+332 continue
+
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = vairDY(i, j, k)
+ enddo
+ enddo
+
+ go to 330
+
+333 continue
+ ! +--w Wind Speed Component (Non Hydrostatic Option)
+ ! + -----------------------------------------------
+#if(NH)
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = wairNH(i, j, k)
+ enddo
+ enddo
+ enddo
+ do j = 1, my
+ do i = 1, mx
+ vartop(i, j) = wairNH(i, j, 1)
+ varbot(i, j) = wairNH(i, j, mz)
+ enddo
+ enddo
+#endif
+ go to 330
+
+ ! +--Potential Temperature
+ ! + ---------------------
+
+334 continue
+
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = pktaDY(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ go to 330
+
+ ! +--Specific Humidity
+ ! + -----------------
+
+335 continue
+#if(iso)
+ is_iso = .true.
+#endif
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qvDY(i, j, k)
+#if(iso)
+ ! turbulent advection of isotopic ratio
+ if(qvDY(i, j, k) > negligible) then
+ do wiso = 1, niso
+ WKxyz1_iso(wiso, i, j, k) = qvDY_iso(wiso, i, j, k) / qvDY(i, j, k)
+ enddo
+ else
+ WKxyz1_iso(wiso, i, j, k) = Rdefault(wiso)
+ endif
+#endif
+ enddo
+ enddo
+ ! end do
+
+ go to 330
+
+ ! +--Cloud Droplets Concentration
+ ! + ----------------------------
+
+336 continue
+
+ if(micphy) then
+
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qwHY(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ endif
+
+ go to 330
+
+ ! +--Ice Crystals Concentration
+ ! + --------------------------
+
+337 continue
+
+ if(micphy) then
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qiHY(i, j, k)
+ enddo
+ enddo
+ ! end do
+ endif
+
+ go to 330
+
+ ! +--Rain Drops Concentration
+ ! + ------------------------
+
+338 continue
+
+ if(micphy) then
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qrHY(i, j, k)
+ enddo
+ enddo
+ ! end do
+ endif
+
+ go to 330
+
+ ! +--Snow Flakes Concentration
+ ! + -------------------------
+
+339 continue
+
+ if(micphy) then
+
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qsHY(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ endif
+
+ go to 330
+
+ ! +--Ice Crystals Number
+ ! + -------------------
+
+340 continue
+
+ if(micphy) then
+
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = ccniHY(i, j, k)
+ enddo
+ enddo
+ ! end do
+
+ endif
+
+ go to 330
+
+#if(TC)
+ ! +--Tracers
+ ! + -------
+
+341 continue
+ itrac = ivar - 10
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = qxTC(i, j, k, itrac)
+ enddo
+ enddo
+ enddo
+ do j = 1, my
+ do i = 1, mx
+ vartop(i, j) = qxTC(i, j, 1, itrac)
+ varbot(i, j) = qsTC(i, j, itrac)
+ enddo
+ enddo
+#endif
+ go to 330
+
+330 continue
+
+ ! +--Boundary Conditions
+ ! + ===================
+ ! do k=1,mz
+ do j = 1, my
+ WKxyz1(1, j, k) = WKxyz1(ip11, j, k)
+ WKxyz1(mx, j, k) = WKxyz1(mx1, j, k)
+#if(iso)
+ if(is_iso) then
+ do wiso = 1, niso
+ WKxyz1_iso(wiso, 1, j, k) = WKxyz1_iso(wiso, ip11, j, k)
+ WKxyz1_iso(wiso, mx, j, k) = WKxyz1_iso(wiso, mx1, j, k)
+ enddo
+ endif
+#endif
+ enddo
+ ! end do
+
+ if(mmy > 1) then
+ ! do k=1,mz
+ do i = 1, mx
+ WKxyz1(i, 1, k) = WKxyz1(i, jp11, k)
+ WKxyz1(i, my, k) = WKxyz1(i, my1, k)
+#if(iso)
+ if(is_iso) then
+ do wiso = 1, niso
+ WKxyz1_iso(wiso, i, 1, k) = WKxyz1_iso(wiso, i, jp11, k)
+ WKxyz1_iso(wiso, i, my, k) = WKxyz1_iso(wiso, i, my1, k)
+ enddo
+ endif
+#endif
+ enddo
+ ! end do
+ endif
+
+ ! +--Lateral Diffusion of non Vectorial Model Variables (c #DF ON)
+ ! + Lateral Diffusion of all Model Variables (c #DF OFF)
+ ! + (proportional to the gradient, terms in sigma surfaces)
+ ! + ==============================================================
+
+ ! +--Diffusion in the x Direction on Sigma Surfaces
+ ! + ----------------------------------------------
+
+ do i = ip11, mx1
+ do j = 1, my
+ WKxyz5(i, j, k) = WKxy3(i, j) * &
+ (WKxy1(i, j) * TUkhx(i, j, k) &
+ * (WKxyz1(ip1(i), j, k) - WKxyz1(i, j, k)) &
+ - WKxy1(im1(i), j) * TUkhx(im1(i), j, k) &
+ * (WKxyz1(i, j, k) - WKxyz1(im1(i), j, k)))
+#if(iso)
+ if(is_iso) then
+ do wiso = 1, niso
+ WKxyz5_iso(wiso, i, j, k) = WKxy3(i, j) * &
+ (WKxy1(i, j) * TUkhx(i, j, k) &
+ * (WKxyz1_iso(wiso, ip1(i), j, k) - WKxyz1_iso(wiso, i, j, k)) &
+ - WKxy1(im1(i), j) * TUkhx(im1(i), j, k) &
+ * (WKxyz1_iso(wiso, i, j, k) - WKxyz1_iso(wiso, im1(i), j, k)))
+ enddo
+ endif
+#endif
+ enddo
+ enddo
+ !XF end do
+
+ ! +--Diffusion in the y Direction on Sigma Surfaces
+ ! + ----------------------------------------------
+
+ if(mmy > 2) then
+ !XF do k=1,mz
+ do j = jp11, my1
+ do i = 1, mx
+ WKxyz5(i, j, k) = WKxyz5(i, j, k) + WKxy3(i, j) * &
+ (WKxy2(i, j) * TUkhy(i, j, k) &
+ * (WKxyz1(i, jp1(j), k) - WKxyz1(i, j, k)) &
+ - WKxy2(i, jm1(j)) * TUkhy(i, jm1(j), k) &
+ * (WKxyz1(i, j, k) - WKxyz1(i, jm1(j), k)))
+#if(iso)
+ if(is_iso) then
+ do wiso = 1, niso
+ WKxyz5_iso(wiso, i, j, k) = WKxyz5_iso(wiso, i, j, k) + WKxy3(i, j) * &
+ (WKxy2(i, j) * TUkhy(i, j, k) &
+ * (WKxyz1_iso(wiso, i, jp1(j), k) - WKxyz1_iso(wiso, i, j, k)) &
+ - WKxy2(i, jm1(j)) * TUkhy(i, jm1(j), k) &
+ * (WKxyz1_iso(wiso, i, j, k) - WKxyz1_iso(wiso, i, jm1(j), k)))
+ enddo
+ endif
+#endif
+ enddo
+ enddo
+ !XF end do
+ endif
+
+ ! +--Update of the Global Variables
+ ! + ==============================
+#if(TC)
+ if(ivar > 10) go to 411
+#endif
+
+ go to(401, 402, 403, 404, 405, 406, 407, 408, 409, 410) ivar
+
+ ! +--u Wind Speed Component
+ ! + ----------------------
+
+401 continue
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ uairDY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ go to 400
+
+ ! +--v Wind Speed Component
+ ! + ----------------------
+
+402 continue
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ vairDY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ go to 400
+
+403 continue
+ ! +--w Wind Speed Component (Non Hydrostatic Option)
+ ! + -----------------------------------------------
+#if(NH)
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ wairNH(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ enddo
+#endif
+ go to 400
+
+ ! +--Potential Temperature
+ ! + ---------------------
+
+404 continue
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ pktaDY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ go to 400
+
+ ! +-- Specific Humidity
+ ! + -----------------
+
+405 continue
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qvDY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+#if(iso)
+ ! restoration of mass from turbulent diffusion of isotopic ratio
+ do wiso = 1, niso
+ qvDY_iso(wiso, i, j, k) = (WKxyz1_iso(wiso, i, j, k) + WKxyz5_iso(wiso, i, j, k) * dtHDif) &
+ * qvDY(i, j, k)
+ enddo
+#endif
+ enddo
+ enddo
+#if(iso)
+ is_iso = .false.
+#endif
+ ! end do
+ go to 400
+
+ ! +--Cloud Droplets Concentration
+ ! + ----------------------------
+
+406 continue
+ if(micphy) then
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qwHY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ endif
+ go to 400
+
+ ! +--Ice Crystals Concentration
+ ! + --------------------------
+
+407 continue
+ if(micphy) then
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qiHY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ endif
+ go to 400
+
+ ! +--Rain Drops Concentration
+ ! + ------------------------
+
+408 continue
+ if(micphy) then
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qrHY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ endif
+ go to 400
+
+ ! +--Snow Flakes Concentration
+ ! + -------------------------
+
+409 continue
+ if(micphy) then
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qsHY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ endif
+ go to 400
+
+ ! +--Ice Crystals Number
+ ! + -------------------
+
+410 continue
+ if(micphy) then
+ ! do k=1,mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ ccniHY(i, j, k) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ ! end do
+ endif
+ go to 400
+
+ ! +--Tracers
+ ! + -------
+411 continue
+#if(TC)
+ itrac = ivar - 10
+ do k = 1, mz
+ do j = jp11, my1
+ do i = ip11, mx1
+ qxTC(i, j, k, itrac) = WKxyz1(i, j, k) + WKxyz5(i, j, k) * dtHDif
+ enddo
+ enddo
+ enddo
+#endif
+400 continue
+ enddo ! ivar = 1, n_kq
+ enddo ! iter = 1, ntDifH
+ ! +--Work Arrays Reset
+ ! + =================
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.00
+ WKxyz2(i, j, k) = 0.00
+ WKxyz3(i, j, k) = 0.00
+ WKxyz4(i, j, k) = 0.00
+ WKxyz5(i, j, k) = 0.00
+ enddo
+ enddo
+ enddo ! k = 1, mz
+ !$OMP END PARALLEL DO
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.00
+ WKxy2(i, j) = 0.00
+ WKxy3(i, j) = 0.00
+ WKxy4(i, j) = 0.00
+ enddo
+ enddo
+
+ return
+endsubroutine turhor_dyn
diff --git a/MAR/code_mar/turhor_kh.f90 b/MAR/code_mar/turhor_kh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8e71cce8efdf18dfc8daffcd71789c49bbaca860
--- /dev/null
+++ b/MAR/code_mar/turhor_kh.f90
@@ -0,0 +1,240 @@
+#include "MAR_pp.def"
+subroutine turhor_kh
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE HORIZONTAL 08-04-2021 MAR |
+ ! | subroutine turhor_kh computes the Horizontal Diffusion Coefficient |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT (via common block) |
+ ! | ^^^^^ uairDY(i,j,k): Horizontal Wind Speed (x-Direction) (m/s) |
+ ! | vairDY(i,j,k): Horizontal Wind Speed (y-Direction) (m/s) |
+ ! | |
+ ! | OUTPUT (via common block) |
+ ! | ^^^^^^ TUkhx(i,j,k): Horizont.Diff.Coefficient (i+1/2,j,k) (m2/s) |
+ ! | TUkhy(i,j,k): Horizont.Diff.Coefficient (i,j+1/2,k) (m2/s) |
+ ! | |
+ ! | REFER.: Tag et al., JAM 18, 1429--1441, 1979 |
+ ! | ^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_tu
+ use mar_wk
+
+ implicit none
+
+ integer i, j, k, m
+
+ ! +--Reset of the Horizontal Diffusion Coefficient
+ ! + =============================================
+
+ ! +--2D Model Version
+ ! + ================
+
+ if(mmy == 1) then
+
+ do k = 1, mz
+ do j = 1, my
+ do i = 1, mx
+ TUkhx(i, j, k) = 0.0
+ TUkhy(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+
+ j = 1
+ do k = 1, mz
+ do i = 1, mx
+ WKxza(i, k) = uairDY(ip1(i), j, k) - uairDY(i, j, k)
+ WKxzb(i, k) = vairDY(ip1(i), j, k) - vairDY(i, j, k)
+ enddo
+ enddo
+
+ do k = 1, mz
+ do i = 1, mx
+ TUkhx(i, j, k) = TUkhff * dxy3(i, j) &
+ * (sqrt(0.5 * (WKxzb(i, k) * WKxzb(i, k)) &
+ + WKxza(i, k) * WKxza(i, k)))
+ WKxza(i, k) = 0.0
+ WKxzb(i, k) = 0.0
+ enddo
+ TUkhx(mx, j, k) = 0.0
+ enddo
+
+ ! +--Upper Absorbing Layer
+ ! + ---------------------
+
+ if(TUkhmx > 0.0) then
+ do k = 1, mzabso
+ do j = 1, my
+ do i = 1, mx
+ TUkhx(i, j, k) = TUkhx(i, j, k) + TUspon(k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ ! +--3D Model Version
+ ! + ================
+
+ else
+
+ !$OMP PARALLEL do private(i,j,k)
+ do k = 1, mz
+
+ do j = 1, my
+ do i = 1, mx
+ TUkhx(i, j, k) = 0.0
+ TUkhy(i, j, k) = 0.0
+ enddo
+ enddo
+
+ ! +--x Direction
+ ! + -----------
+
+ do i = 1, mx
+ do j = jp11, my1
+ WKxyz1(i, j, k) = &
+ vairDY(ip1(i), j, k) - vairDY(i, j, k)
+ WKxyz3(i, j, k) = &
+ uairDY(ip1(i), j, k) - uairDY(i, j, k)
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = 1, mx
+ WKxyz2(i, j, k) = &
+ uairDY(i, jp1(j), k) - uairDY(i, jm1(j), k)
+ WKxyz4(i, j, k) = &
+ vairDY(i, jp1(j), k) - vairDY(i, jm1(j), k)
+ WKxyz5(i, j, k) = &
+ vairDY(i, jp1(j), k)
+ WKxyz6(i, j, k) = &
+ vairDY(i, jm1(j), k)
+ enddo
+ enddo
+
+ do i = 1, mx
+ do j = jp11, my1
+ TUkhx(i, j, k) = TUkhff * dxy3(i, j) * (sqrt( &
+ 0.5 * ((WKxyz1(i, j, k) &
+ + 0.5 * (WKxyz2(i, j, k)))**2) &
+ + (WKxyz3(i, j, k))**2 &
+ + (0.25 * (WKxyz4(i, j, k) &
+ + WKxyz5(ip1(i), j, k) &
+ - WKxyz6(ip1(i), j, k)))**2))
+
+ ! The 3 previous Loops Stand for the following non-vectorized Loop:
+ ! TUkhx(i,j,k) = TUkhff * dxy3(i, j) *(sqrt( &
+ ! 0.5*((vairDY(ip1(i), j ,k)-vairDY(i, j ,k) &
+ ! + 0.5* (uairDY(i ,jp1(j),k)-uairDY(i,jm1(j),k)))**2) &
+ ! + (uairDY(ip1(i), j ,k)-uairDY(i, j ,k)) **2 &
+ ! +(0.25*(vairDY(i ,jp1(j),k)-vairDY(i,jm1(j),k) &
+ ! +vairDY(ip1(i),jp1(j),k) &
+ ! -vairDY(ip1(i),jm1(j),k)))**2))
+ enddo
+ enddo
+
+ ! +--y Direction
+ ! + -----------
+
+ do j = 1, my
+ do i = ip11, mx1
+ WKxyz1(i, j, k) = &
+ vairDY(i, jp1(j), k) - vairDY(i, j, k)
+ WKxyz3(i, j, k) = &
+ uairDY(i, jp1(j), k) - uairDY(i, j, k)
+ enddo
+ enddo
+
+ do i = ip11, mx1
+ do j = 1, my
+ WKxyz2(i, j, k) = &
+ uairDY(ip1(i), j, k) - uairDY(im1(i), j, k)
+ WKxyz4(i, j, k) = &
+ vairDY(ip1(i), j, k) - vairDY(im1(i), j, k)
+ WKxyz5(i, j, k) = &
+ vairDY(ip1(i), j, k)
+ WKxyz6(i, j, k) = &
+ vairDY(im1(i), j, k)
+ enddo
+ enddo
+
+ do j = 1, my
+ do i = ip11, mx1
+ TUkhy(i, j, k) = TUkhff * dxy3(i, j) * (sqrt( &
+ 0.5 * ((WKxyz1(i, j, k) &
+ + 0.5 * (WKxyz2(i, j, k)))**2) &
+ + (WKxyz3(i, j, k))**2 &
+ + (0.25 * (WKxyz4(i, j, k) &
+ + WKxyz5(i, jp1(j), k) &
+ - WKxyz6(i, jp1(j), k)))**2))
+
+ ! The 3 previous Loops Stand for the following non-vectorized Loop:
+ ! TUkhy(i,j,k) = TUkhff * dxy3(i, j) *(sqrt( &
+ ! 0.5*((vairDY( i ,jp1(j),k)-vairDY( i ,j,k) &
+ ! + 0.5* (uairDY(ip1(i), j ,k)-uairDY(im1(i),j,k)))**2) &
+ ! + (uairDY( i ,jp1(j),k)-uairDY( i ,j,k)) **2 &
+ ! +(0.25*(vairDY(ip1(i), j ,k)-vairDY(im1(i),j,k) &
+ ! +vairDY(ip1(i),jp1(j),k) &
+ ! -vairDY(im1(i),jp1(j),k)))**2))
+ enddo
+ enddo
+
+ do i = 1, mx
+ do j = jp11, my1
+ WKxyz1(i, j, k) = 0.
+ WKxyz2(i, j, k) = 0.
+ WKxyz3(i, j, k) = 0.
+ WKxyz4(i, j, k) = 0.
+ WKxyz5(i, j, k) = 0.
+ WKxyz6(i, j, k) = 0.
+ enddo
+ enddo
+
+ ! +--Upper Absorbing Layer
+ ! + ---------------------
+
+ if(k <= mzabso .and. TUkhmx > 0.0) then
+
+ do j = 1, my
+ do i = 1, mx
+ TUkhx(i, j, k) = TUkhx(i, j, k) + TUspon(k)
+ TUkhy(i, j, k) = TUkhy(i, j, k) + TUspon(k)
+ enddo
+ enddo
+ endif
+ enddo
+ !$OMP END PARALLEL DO
+
+ endif
+
+#if(OB)
+ ! +--Lateral Boundary Values
+ ! + -----------------------
+ if(mmx > 1) then
+ do k = 1, mz
+ do j = 1, my
+ TUkhx(1, j, k) = 0.0
+ TUkhx(mx, j, k) = 0.0
+ TUkhy(1, j, k) = 0.0
+ TUkhy(mx, j, k) = 0.0
+ enddo
+ enddo
+ endif
+ if(mmy > 1) then
+ do k = 1, mz
+ do i = 1, mx
+ TUkhx(i, 1, k) = 0.0
+ TUkhx(i, my, k) = 0.0
+ TUkhy(i, 1, k) = 0.0
+ TUkhy(i, my, k) = 0.0
+ enddo
+ enddo
+ endif
+#endif
+ return
+end
diff --git a/MAR/code_mar/turtke_advh.f90 b/MAR/code_mar/turtke_advh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6da0aa86f51ccf960458397d81dd67ac827d09a3
--- /dev/null
+++ b/MAR/code_mar/turtke_advh.f90
@@ -0,0 +1,122 @@
+subroutine turtke_advh(dt_dif)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE (TKE) 15-04-2021 MAR |
+ ! | subroutine turtke_advh includes TKE Horizontal Advection Contribution|
+ ! | solved by a 1st Order Accurate in Space Upstream Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT : dt_dif: Local Time Step (s) |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | |
+ ! | INPUT / OUTPUT: The Vertical Turbulent Fluxes are included for: |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | a) Turbulent Kinetic Energy ect_TE(mx,my,mz) [m2/s2] |
+ ! | b) Turbulent Kinetic Energy Dissipation eps_TE(mx,my,mz) [m2/s3] |
+ ! | |
+ ! | REMARK : The Advected Variables Lateral Boundary Conditions |
+ ! | ^^^^^^^^ are Fixed Implicitely |
+ ! | 1) inflow => no change |
+ ! | 2) outflow => advected Value |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_te
+ use mar_wk
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+ real dt_dif
+
+ ! +--Local Variables
+ ! + ================
+ integer i, j, k, m
+ real dti, dtxe(mx, my), dtye(mx, my), tran
+
+ ! +--Parameters
+ ! + ==========
+ dti = 1.0 / dt_dif
+ do j = 1, my
+ do i = 1, mx
+ dtxe(i, j) = dt_dif / dx3(i, j)
+ dtye(i, j) = dt_dif / dy3(i, j)
+ enddo
+ enddo
+
+ ! +--Courant Number
+ ! + ==============
+ !$OMP PARALLEL do private (i,j,k,tran)
+ do k = 1, mmz1
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = -max(zero, demi * (uairDY(i, j, k) + uairDY(i, j, kp1(k)))) &
+ * dtxe(i, j)
+ WKxyz2(i, j, k) = -min(zero, demi * (uairDY(i, j, k) + uairDY(i, j, kp1(k)))) &
+ * dtxe(i, j)
+ WKxyz3(i, j, k) = -max(zero, demi * (vairDY(i, j, k) + vairDY(i, j, kp1(k)))) &
+ * dtye(i, j)
+ WKxyz4(i, j, k) = -min(zero, demi * (vairDY(i, j, k) + vairDY(i, j, kp1(k)))) &
+ * dtye(i, j)
+ ! +...Velocities V are computed in the layers (i.e. at k+1/2)
+ ! + Interpolation based on V=0 at the Surface (very approximative)
+
+ enddo
+ enddo
+ ! end do
+
+ ! +--Advection (x-Direction)
+ ! + =======================
+ ! do k=1,mmz1
+ do i = ip11, mx1
+ do j = jp11, my1
+ tran = WKxyz1(i, j, k) * (ect_TE(i, j, k) - ect_TE(im1(i), j, k)) &
+ + WKxyz2(i, j, k) * (ect_TE(ip1(i), j, k) - ect_TE(i, j, k))
+ tranTE(i, j, k) = tranTE(i, j, k) + tran * dti
+ ect_TE(i, j, k) = ect_TE(i, j, k) + tran
+ eps_TE(i, j, k) = eps_TE(i, j, k) &
+ + WKxyz1(i, j, k) * (eps_TE(i, j, k) - eps_TE(im1(i), j, k)) &
+ + WKxyz2(i, j, k) * (eps_TE(ip1(i), j, k) - eps_TE(i, j, k))
+ enddo
+ enddo
+ ! end do
+
+ ! +--Advection (y-Direction)
+ ! + =======================
+ if(mmy > 1) then
+ ! do k=1,mmz1
+ do j = jp11, my1
+ do i = ip11, mx1
+ tran = WKxyz3(i, j, k) * (ect_TE(i, j, k) - ect_TE(i, jm1(j), k)) &
+ + WKxyz4(i, j, k) * (ect_TE(i, jp1(j), k) - ect_TE(i, j, k))
+ tranTE(i, j, k) = tranTE(i, j, k) + tran * dti
+ ect_TE(i, j, k) = ect_TE(i, j, k) + tran
+ eps_TE(i, j, k) = eps_TE(i, j, k) &
+ + WKxyz3(i, j, k) * (eps_TE(i, j, k) - eps_TE(i, jm1(j), k)) &
+ + WKxyz4(i, j, k) * (eps_TE(i, jp1(j), k) - eps_TE(i, j, k))
+ enddo
+ enddo
+ ! end do
+ endif
+
+ ! +--Work Arrays Reset
+ ! + =================
+ ! do k=1,mz
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+endsubroutine turtke_advh
diff --git a/MAR/code_mar/turtke_advv.f90 b/MAR/code_mar/turtke_advv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..abdcb6bdc48b15d14be91de0820303cac1d4fe90
--- /dev/null
+++ b/MAR/code_mar/turtke_advv.f90
@@ -0,0 +1,125 @@
+subroutine turtke_advv(dt_dif)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE (TKE) 14-09-2001 MAR |
+ ! | subroutine turtke_advv includes TKE Vertical Advection Contribution |
+ ! | solved by a 1st Order Accurate in Space Upstream Scheme |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT / OUTPUT: The Vertical Turbulent Fluxes are included for: |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | a) Turbulent Kinetic Energy ect_TE(mx,my,mz) [m2/s2] |
+ ! | b) Turbulent Kinetic Energy Dissipation eps_TE(mx,my,mz) [m2/s3] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_te
+ use mar_wk
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ real dt_dif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ real tran
+
+ ! +--Vertical Courant Number
+ ! + =======================
+
+ !$OMP PARALLEL do private(i,j,k,tran)
+ do j = 1, my
+
+ if(staggr) then
+ do k = 1, mmz1
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz3(i, j, k) = psigDY(i, j, k)
+ enddo
+ ! end do
+ enddo
+ else
+ do k = 1, mmz1
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz3(i, j, k) = 0.50 * (psigDY(i, j, kp1(k)) + psigDY(i, j, k))
+ enddo
+ ! end do
+ enddo
+ endif
+
+ do k = 1, mmz1
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = -max(zero, WKxyz3(i, j, k)) &
+ * dt_dif / (pstDYn(i, j) * dsigm1(k))
+ WKxyz2(i, j, k) = -min(zero, WKxyz3(i, j, k)) &
+ * dt_dif / (pstDYn(i, j) * dsigm1(k + 1))
+ enddo
+ ! end do
+ enddo
+
+ k = mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = -max(zero, WKxyz3(i, j, k)) &
+ * dt_dif / (pstDYn(i, j) * dsigm1(k))
+ ! end do
+ enddo
+
+ ! +--Vertical Advection of TKE and TKE Dissipation
+ ! + =============================================
+
+ do k = kp1(1), mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz4(i, j, k) = ect_TE(i, j, k) - ect_TE(i, j, k - 1)
+ WKxyz5(i, j, k) = eps_TE(i, j, k) - eps_TE(i, j, k - 1)
+ enddo
+ ! end do
+ enddo
+
+ do k = kp1(1), mmz1
+ ! do j=1,my
+ do i = 1, mx
+ tran = zero
+ tran = WKxyz1(i, j, k) * WKxyz4(i, j, k) &
+ + WKxyz2(i, j, k) * WKxyz4(i, j, k + 1)
+ ect_TE(i, j, k) = ect_TE(i, j, k) + tran
+ eps_TE(i, j, k) = eps_TE(i, j, k) &
+ + WKxyz1(i, j, k) * WKxyz5(i, j, k) &
+ + WKxyz2(i, j, k) * WKxyz5(i, j, k + 1)
+
+ tranTE(i, j, k) = tranTE(i, j, k) + tran / dt_dif
+
+ enddo
+ ! end do
+ enddo
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+endsubroutine turtke_advv
diff --git a/MAR/code_mar/turtke_difh.f90 b/MAR/code_mar/turtke_difh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d21a2dacd6ee675ef841cbb1ddaa856ccec520a3
--- /dev/null
+++ b/MAR/code_mar/turtke_difh.f90
@@ -0,0 +1,156 @@
+subroutine turtke_difh(dt_dif)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE (TKE) 08-09-2017 MAR |
+ ! | subroutine turtke_difh includes TKE Horizontal Diffusion Contribution|
+ ! | to Turbulent Kinetic Energy (ect_TE) and Dissipation (eps_TE) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT:TUkhx(mx,my,mz): Horizontal Diffusion Coefficient (x-Direction) |
+ ! | ^^^^^ TUkhy(mx,my,mz): Horizontal Diffusion Coefficient (y-Direction) |
+ ! | |
+ ! | INPUT / OUTPUT |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | The Horizontal Diffusion and Correction Terms are included for : |
+ ! | a) Turbulent Kinetic Energy ect_TE(mx,my,mz) [m2/s2] |
+ ! | b) Turbulent Kinetic Energy Dissipation eps_TE(mx,my,mz) [m2/s2] |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_te
+ use mar_tu
+ use mar_wk
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ real dt_dif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ real tran, dx2inv
+
+ ! +--Computes Horizontal Diffusion using an Explicit Scheme
+ ! + ======================================================
+
+ do i = 1, mx1
+ do j = 1, my
+ WKxy1(i, j) = 0.50 * (pstDY(i, j) + pstDY(ip1(i), j))
+ enddo
+ enddo
+
+ do j = 1, my1
+ do i = 1, mx
+ WKxy2(i, j) = 0.50 * (pstDY(i, j) + pstDY(i, jp1(j)))
+ enddo
+ enddo
+
+ dx2inv = 1.d0 / dx / dx
+ do j = 1, my
+ do i = 1, mx
+ WKxy3(i, j) = dx2inv / pstDY(i, j)
+ enddo
+ enddo
+
+ !$OMP PARALLEL do private (i,j,k,tran)
+ ! + ================
+ do k = kp1(1), mmz1
+ ! + ================
+
+ ! +--Horizontal Diffusion, x-Direction
+ ! + =================================
+
+ do i = ip11, mx1
+ do j = jp11, my1
+ ! +
+ tran = WKxy3(i, j) &
+ * (WKxy1(i, j) * TUkhx(i, j, k) &
+ * (ect_TE(ip1(i), j, k) - ect_TE(i, j, k)) &
+ - WKxy1(im1(i), j) * TUkhx(im1(i), j, k) &
+ * (ect_TE(i, j, k) - ect_TE(im1(i), j, k)))
+ tranTE(i, j, k) = tranTE(i, j, k) + tran
+ WKxyz1(i, j, k) = dt_dif * tran
+
+ WKxyz2(i, j, k) = dt_dif * WKxy3(i, j) &
+ * (WKxy1(i, j) * TUkhx(i, j, k) &
+ * (eps_TE(ip1(i), j, k) - eps_TE(i, j, k)) &
+ - WKxy1(im1(i), j) * TUkhx(im1(i), j, k) &
+ * (eps_TE(i, j, k) - eps_TE(im1(i), j, k)))
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ ect_TE(i, j, k) = ect_TE(i, j, k) + WKxyz1(i, j, k)
+ eps_TE(i, j, k) = eps_TE(i, j, k) + WKxyz2(i, j, k)
+ enddo
+ enddo
+
+ ! +--Horizontal Diffusion, y-Direction
+ ! + =================================
+
+ if(mmy >= 2) then
+
+ do j = jp11, my1
+ do i = ip11, mx1
+
+ tran = WKxy3(i, j) &
+ * (WKxy2(i, j) * TUkhy(i, j, k) &
+ * (ect_TE(i, jp1(j), k) - ect_TE(i, j, k)) &
+ - WKxy2(i, jm1(j)) * TUkhy(i, jm1(j), k) &
+ * (ect_TE(i, j, k) - ect_TE(i, jm1(j), k)))
+ tranTE(i, j, k) = tranTE(i, j, k) + tran
+ WKxyz1(i, j, k) = dt_dif * tran
+
+ WKxyz2(i, j, k) = dt_dif * WKxy3(i, j) &
+ * (WKxy2(i, j) * TUkhy(i, j, k) &
+ * (eps_TE(i, jp1(j), k) - eps_TE(i, j, k)) &
+ - WKxy2(i, jm1(j)) * TUkhy(i, jm1(j), k) &
+ * (eps_TE(i, j, k) - eps_TE(i, jm1(j), k)))
+ enddo
+ enddo
+
+ do j = jp11, my1
+ do i = ip11, mx1
+ ect_TE(i, j, k) = ect_TE(i, j, k) + WKxyz1(i, j, k)
+ eps_TE(i, j, k) = eps_TE(i, j, k) + WKxyz2(i, j, k)
+ enddo
+ enddo
+
+ endif
+
+ do j = 1, my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ enddo
+ enddo
+
+ ! + ======
+ enddo
+ ! + ======
+ !$OMP END PARALLEL DO
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ do j = 1, my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ WKxy4(i, j) = 0.0
+ enddo
+ enddo
+
+ return
+endsubroutine turtke_difh
diff --git a/MAR/code_mar/turtke_difv.f90 b/MAR/code_mar/turtke_difv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..97fc8142d0489d253a4e49cd120f192a4c6be0ed
--- /dev/null
+++ b/MAR/code_mar/turtke_difv.f90
@@ -0,0 +1,306 @@
+#include "MAR_pp.def"
+subroutine turtke_difv(dt_dif, alphaD)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE (TKE) 11-14-2022 MAR |
+ ! | subroutine turtke_difv includes TKE Vertical Turbulence Contribution |
+ ! | to Turbulent Kinetic Energy (ect_TE) and Dissipation (eps_TE) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | INPUT: TUkvm(mx,my,mz): Vertical Turbulent Coeffic.(momentum) [m2/s2] |
+ ! | ^^^^^^ |
+ ! | |
+ ! | INPUT / OUTPUT: The Vertical Turbulent Fluxes are included for: |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | a) Turbulent Kinetic Energy ect_TE(mx,my,mz) [m2/s2] |
+ ! | b) Turbulent Kinetic Energy Dissipation eps_TE(mx,my,mz) [m2/s3] |
+ ! | |
+ ! | #OPTIONS: #De: Dirichlet Type Top Boundary Condit. for ect_TE & eps_TE |
+ ! | #^^^^^^^^ |
+ ! +------------------------------------------------------------------------+
+
+ use marphy
+ use mardim
+ use margrd
+ use mar_dy
+ use mar_te
+ use mar_tu
+ use mar_wk
+#if(De)
+ ! cCA : MAR_DI.inc doesn't exist
+ ! include 'MAR_DI.inc'
+#endif
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ real dt_dif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ integer k1
+ real sige, sigk
+ real sige0, sigk0, sigek, alpha, beta, ab, alphaD
+
+ ! +--DATA
+ ! + ====
+
+ ! Bintanja , 2000, BLM (95),milieu p. 355 : 1/sig_e = 1./1.16 = 0.862
+ data sige/0.862e0/
+ ! Duynkerke, 1988, JAS (45), end a. p.868 : 1/sig_e = 1./2.38 = 0.420
+#if(PD)
+ data sige0/0.420e0/
+#endif
+ ! Kitada , 1987, BLM (41), p.220 : 1/sig_e = 1./1.30 = 0.769
+#if(KI)
+ data sige0/0.769e0/
+#endif
+ ! For TKE Closure (Therry and Lacarrere, 1983)
+#if(Kl)
+ data sige0/0.420e0/
+#endif
+
+ ! Duynkerke, 1988, JAS (45), end a. p.868 : 1/sig_k = 1./1.00=1.000
+ data sigk/1.000e0/
+ ! Kitada , 1987, BLM (41), p.220 : 1/sig_k = 1./1.00=1.000
+#if(KI)
+ data sigk0/1.000e0/
+#endif
+ ! Schayes and Thunis, Contribution 60 Inst.Astr.Geoph.(1990) p.6
+#if(Kl)
+ data sigk0/1.200e0/
+#endif
+
+#if(PD)
+ sige = sige0
+#endif
+#if(KI)
+ sige = sige0
+#endif
+#if(Kl)
+ sige = sige0
+#endif
+ sigek = sige / sigk
+
+ ! +--Parameters for the Numerical Scheme of Vertical Turbulent Transport
+ ! + ===================================================================
+
+ alpha = alphaD ! Expliciteness := 0 (positive definite)
+ beta = 1.00 - alpha ! Impliciteness
+ ab = alpha / beta !
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ !$OMP PARALLEL do private (i,j,k,k1)
+ do j = 1, my
+ do k = 1, mz
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ enddo
+ enddo
+ ! end do
+
+ ! +--Vertical Diffusion of Turbulent Kinetic Energy
+ ! + ==============================================
+
+ ! +--Tridiagonal Matrix Coefficients - ect_TE
+ ! + ----------------------------------------
+
+ do k = mmz2, 1, -1
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = -gravi2 * (TUkvm(i, j, k) + TUkvm(i, j, k + 1) &
+ ) * 0.50 * beta * sigk &
+ * romiDY(i, j, k) * rolvDY(i, j, k) &
+ / (pstDY2(i, j) * dsigm1(k) * dsig_1(k))
+ enddo
+ ! end do
+
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz3(i, j, kp1(k)) = WKxyz1(i, j, k) * dsigm1(k) / dsigm1(kp1(k)) &
+ / rolvDY(i, j, k) * rolvDY(i, j, k + 1)
+ enddo
+ ! end do
+
+ enddo
+
+ do k = 1, mmz1
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * dt_dif
+ WKxyz3(i, j, k) = WKxyz3(i, j, k) * dt_dif
+ WKxyz2(i, j, k) = 1.0 - WKxyz3(i, j, k) - WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Second Member of the Tridiagonal System - ect_TE
+ ! + ------------------------------------------------
+
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, 1) = &
+ WKxyz1(i, j, 1) * ab * (ect_TE(i, j, 1) - ect_TE(i, j, kp1(1)))
+#if(De)
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = ect_DI(i, j)
+#endif
+ enddo
+ ! end do
+
+ do k = kp1(1), mmz2
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (ect_TE(i, j, k) - ect_TE(i, j, kp1(k))) &
+ - WKxyz3(i, j, k) * ab * (ect_TE(i, j, km1(k)) - ect_TE(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, mmz1) = -(alpha * ect_TE(i, j, mmz1) - ect_TE(i, j, mz)) &
+ * gravi2 * (TUkvm(i, j, mmz1) + TUkvm(i, j, mmz2) &
+ ) * 0.50 &
+ * romiDY(i, j, mmz1) * romiDY(i, j, mmz1) &
+ / (pstDY2(i, j) * dsigm1(mmz1) * dsig_1(mmz1)) &
+ - WKxyz3(i, j, mmz1) * ab * (ect_TE(i, j, mmz2) - ect_TE(i, j, mmz1))
+ enddo
+ ! end do
+
+ ! +--Tridiagonal Matrix Inversion - ect_TE
+ ! + -------------------------------------
+
+ k1 = 1
+#if(De)
+ k1 = 2
+#endif
+ do k = k1, mz
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + ect_TE(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! + ************
+ call MARgz_1mx1my(1, mmz1, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mmz1
+ ! do j= 1,my
+ do i = 1, mx
+ tranTE(i, j, k) = tranTE(i, j, k) + (WKxyz7(i, j, k) - ect_TE(i, j, k)) &
+ / dt_dif
+ ect_TE(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Vertical Diffusion of Dissipation
+ ! + =================================
+
+ ! +--Update Tridiagonal Matrix Coefficients - eps_TE
+ ! + -----------------------------------------------
+
+ do k = 1, mmz1
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = WKxyz1(i, j, k) * sigek
+ WKxyz3(i, j, k) = WKxyz3(i, j, k) * sigek
+ WKxyz2(i, j, k) = 1.0 - WKxyz3(i, j, k) - WKxyz1(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Second Member of the Tridiagonal System - eps_TE
+ ! + ------------------------------------------------
+
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, 1) = &
+ WKxyz1(i, j, 1) * ab * (eps_TE(i, j, 1) - eps_TE(i, j, kp1(1)))
+#if(De)
+ WKxyz1(i, j, 1) = 0.0
+ WKxyz2(i, j, 1) = 1.0
+ WKxyz4(i, j, 1) = eps_DI(i, j)
+#endif
+ enddo
+ ! end do
+
+ do k = kp1(1), mmz2
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, k) = &
+ WKxyz1(i, j, k) * ab * (eps_TE(i, j, k) - eps_TE(i, j, kp1(k))) &
+ - WKxyz3(i, j, k) * ab * (eps_TE(i, j, km1(k)) - eps_TE(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, mmz1) = -(alpha * eps_TE(i, j, mmz1) - eps_TE(i, j, mz)) &
+ * gravi2 * (TUkvm(i, j, mmz1) + TUkvm(i, j, mmz2) &
+ ) * 0.50 &
+ * romiDY(i, j, mmz1) * romiDY(i, j, mmz1) &
+ / (pstDY2(i, j) * dsigm1(mmz1) * dsig_1(mmz1)) &
+ - WKxyz3(i, j, mmz1) * ab * (eps_TE(i, j, mmz2) - eps_TE(i, j, mmz1))
+ enddo
+ ! end do
+
+ ! +--Tridiagonal Matrix Inversion - eps_TE
+ ! + -------------------------------------
+
+ k1 = 1
+#if(De)
+ k1 = 2
+#endif
+ do k = k1, mz
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz4(i, j, k) = WKxyz4(i, j, k) + eps_TE(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! + ************
+ call MARgz_1mx1my(1, mmz1, j, WKxyz1, WKxyz2, WKxyz3, WKxyz4, WKxyz7)
+ ! + ************
+
+ do k = 1, mmz1
+ ! do j= 1,my
+ do i = 1, mx
+ eps_TE(i, j, k) = WKxyz7(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ do k = 1, mz
+ ! do j= 1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.00
+ WKxyz2(i, j, k) = 0.00
+ WKxyz3(i, j, k) = 0.00
+ WKxyz4(i, j, k) = 0.00
+ WKxyz7(i, j, k) = 0.00
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+ return
+endsubroutine turtke_difv
diff --git a/MAR/code_mar/turtke_gen.f90 b/MAR/code_mar/turtke_gen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4f091b7ac2a18341ff91a6c9bea070a31fb43c49
--- /dev/null
+++ b/MAR/code_mar/turtke_gen.f90
@@ -0,0 +1,1089 @@
+#include "MAR_pp.def"
+subroutine turtke_gen(dt_dif)
+ ! +------------------------------------------------------------------------+
+ ! | MAR TURBULENCE (TKE) XF 09-11-2020 MAR |
+ ! | subroutine turtke_gen includes 1 1/2 Vertical Turbulence Closures |
+ ! | |
+ ! +------------------------------------------------------------------------+
+ ! | |
+ ! | METHOD: 1. `Standard' Closure of Turbulence: |
+ ! | ^^^^^^^ E - epsilon , Duynkerke, JAS 45, 865--880, 1988 |
+ ! | .OR. 2. E - epsilon , Huang and Raman, BLM 55, 381--407, 1991 |
+ ! | .OR. 3. TKE , Therry et Lacarrere, BLM 25, 63-- 88, 1983 |
+ ! | |
+ ! | INPUT : itexpe: Nb of iterations |
+ ! | ^^^^^^^^ dt_dif: Local Time Step (s) |
+ ! | explIO: Experiment Label (s) |
+ ! | |
+ ! | INPUT / OUTPUT: The Vertical Turbulent Fluxes are included for: |
+ ! | ^^^^^^^^^^^^^^ |
+ ! | a) Turbulent Kinetic Energy ect_TE(mx,my,mz) (m2/s2) |
+ ! | b) Turbulent Kinetic Energy Dissipation eps_TE(mx,my,mz) (m2/s3) |
+ ! | |
+ ! | OUTPUT : TUkvm(i,j,k): vertical diffusion coeff. for momentum (m2/s) |
+ ! | ^^^^^^^^ TUkvh(i,j,k): vertical diffusion coeff. for heat... (m2/s) |
+ ! | zi__TE(i,j) : inversion height (m) |
+ ! | |
+ ! | OPTIONS: #De: Dirichlet Type Top Boundary Condit. for ect_TE & eps_TE |
+ ! | ^^^^^^^^ #WE: Output on MAR.TKE (unit 29) |
+ ! | |
+ ! +------------------------------------------------------------------------+
+
+ use marctr
+ use marphy
+ use mardim
+ use margrd
+ use mar_ge
+ use mar_dy
+ use mar_te
+ use mar_tu
+ use mar_hy
+ use mar_sl
+ use mar_wk
+ use mar_io
+#if(De)
+ ! cCA : MAR_Di.inc does not exist
+ ! use mar_di
+#endif
+
+ implicit none
+
+ ! +--Global Variables
+ ! + ================
+
+ real dt_dif
+
+ ! +--Local Variables
+ ! + ================
+
+ integer i, j, k, m
+ logical log_KA
+ integer locTKE, mz__KA
+ common / turtke_gen_loc / locTKE, mz__KA
+
+ integer i5, n5, kect, ke
+#if(WE)
+ integer m30, m31
+#endif
+
+ real aalme(mx, mz)
+ real aalmk(mx, mz)
+ real flott(mx, mz)
+
+ real epse, epsd, ectmin, turmx, dkect
+ real sqrcmu, sqrcmu0
+ real cmu, c1ep, c2ep, rc1c2, betahr, voninv
+ real cmu0, c1ep0, c2ep0
+ real ectcrt, akz, alme, almk, pousse
+ real hrel, base
+ real epslme, ectnew, produc, factur, zeta, stab_s, phimm
+ real edtnum, edtden
+
+ real phim, dzlev
+ real sature, sgnLMO, absLMO, se
+ real alamb, Ri_Sat
+ real fac_Ri, vuzvun, Kz_vun
+ real kz_max, kz_mix, kz2mix, KvhMax(mx, my, mz)
+
+ ! +--DATA
+ ! + ====
+
+ data epse/0.00000100/
+ data epsd/0.00000001/
+
+ ! +... ectmin:Minimum SBL turbulent kinetic energy
+ data ectmin/0.00010000/
+
+ ! +...Bintanja , 2000, BLM (95),milieu p. 355
+ data cmu/0.090/
+#if(PD)
+ ! +...Duynkerke, 1988, JAS (45), haut p. 868
+ data cmu0/0.033/
+#endif
+#if(KI)
+ ! +...Kitada , 1987, BLM (41), haut p.220
+ data cmu0/0.090/
+#endif
+ ! +...Bintanja , 2000, BLM (95),milieu p. 355
+ data sqrcmu/3.333/
+#if(PD)
+ ! +...Duynkerke, 1988, JAS (45), (19) p. 869 :(c_mu)^1/2=(0.033)^1/2=5.50
+ data sqrcmu0/5.500/
+#endif
+#if(KI)
+ ! +...Kitada , 1987, BLM (41), p.220 :(c_mu)^1/2=(0.090)^1/2=3.333
+ data sqrcmu0/3.333/
+#endif
+#if(Kl)
+ ! +...Schayes and Thunis, 1990, Contrib. 60 Inst.Astr.Geoph. p.8
+ data sqrcmu0/4.000/
+#endif
+
+ ! +...Duynkerke, 1988, JAS (45),milieu p. 868
+ ! +...Bintanja , 2000, BLM (95),milieu p. 355
+ data c1ep/1.46/
+#if(KI)
+ ! +...Kitada , 1987, BLM (41), haut p.220
+ data c1ep0/1.44/
+#endif
+ ! +...Bintanja , 2000, BLM (95),milieu p. 355
+ data c2ep/1.92/
+#if(PD)
+ ! +...Duynkerke, 1988, JAS (45),milieu p. 868
+ data c2ep0/1.83/
+#endif
+#if(KI)
+ ! +...Kitada , 1987, BLM (41), haut p.220
+ data c2ep0/1.92/
+#endif
+
+#if(HR)
+ ! +...Huang and Raman, 1991, BLM (55), p.386 and (A22) p.405
+ data betahr/2.00/
+#endif
+
+ data alamb/0.1/! 1 / 10 m
+ data Ri_Sat/2.0/! Mahalov&al., 2004, GRL
+#if(PD)
+ cmu = cmu0
+#endif
+#if(KI)
+ cmu = cmu0
+#endif
+#if(PD)
+ sqrcmu = sqrcmu0
+#endif
+#if(KI)
+ sqrcmu = sqrcmu0
+#endif
+#if(Kl)
+ sqrcmu = sqrcmu0
+#endif
+#if(KI)
+ c1ep = c1ep0
+#endif
+#if(PD)
+ c2ep = c2ep0
+#endif
+#if(KI)
+ c2ep = c2ep0
+#endif
+
+ rc1c2 = c1ep / c2ep
+
+ ! +--Parameters
+ ! + ==========
+
+ voninv = 1./vonkar
+
+ n5 = 5
+ n5 = min(mx, n5)
+
+ ! +--Initialisation
+ ! + ==============
+
+ if(.not. ini_KA_TE) then
+ ini_KA_TE = .true.
+ mz__KA = mz1
+11 continue
+ if(zsigma(mz__KA) > 5. .OR. mz__KA <= 1) go to 10
+ mz__KA = mz__KA - 1
+ go to 11
+10 continue
+ write(6, 1000) mz - mz__KA
+1000 format(/, ' TKE: Moving Average until mz -', i2, ' Level',/)
+ endif
+
+ if(locTKE == 0 .and. itexpe <= 1) then
+
+ log_KA = .true.
+#if(Kl)
+ log_KA = .false.
+ if(log_KA) then
+ write(6, 6000)
+6000 format('!?%@&* Conflicting Use of #KA and #Kl', &
+ ' ==> Emergency EXIT in turtke_gen', 6x, &
+ ' ### do NOT PRE-PROCESS #KA with #Kl ###')
+ STOP
+ endif
+#endif
+
+ ! +--Minimum Vertical Turbulent Diffusion Coefficient (ARPS.4.0 Users Guide,
+ ! + ------------------------------------------------ fin para 6.3.4 p.143)
+
+ do k = 1, mz1
+ dzlev = zsigma(k) - zsigma(k + 1)
+ TUmin(k) = akmol
+#if(ARPS)
+ TUmin(k) = min(0.15, epsi * dzlev * dzlev)
+#endif
+ enddo
+ k = mz
+ dzlev = zsigma(k)
+ TUmin(k) = akmol
+#if(ARPS)
+ TUmin(k) = min(0.15, epsi * dzlev * dzlev)
+#endif
+
+ endif
+
+ ! +--Initial E,e
+ ! + -----------
+
+!$OMP PARALLEL do &
+!$OMP private(i,j,k,hrel,sature,base,sgnLMO,absLMO,dkect, &
+!$OMP akz,alme,almk,pousse,epslme,ectnew,produc,factur, &
+!$OMP se,ke,edtden,edtnum,kz2mix,kz_max,kz_mix, &
+!$OMP Kz_vun,fac_Ri,vuzvun)
+ do j = 1, my
+ if(locTKE == 0 .and. itexpe <= 1) then
+ do k = 1, mz
+ do i = 1, mx
+ ect_TE(i, j, k) = epse
+ eps_TE(i, j, k) = epsd
+ ! +... These initial values of TKE and epsilon correspond to K ~ Kmol
+
+ TUkvm(i, j, k) = akmol
+ TUkvh(i, j, k) = akmol
+ enddo
+ enddo
+ ! end do
+
+ ! do j=1,my
+ do i = 1, mx
+ zi__TE(i, j) = max(gpmiDY(i, j, mz) * grvinv - sh(i, j), &
+ zi__TE(i, j))
+ enddo
+ ! end do
+
+ ! +--Verification: TKE must be Positive Definite
+ ! + ===========================================
+
+ else
+ ! do j=1,my
+ do k = 1, mz
+ do i = 1, mx
+ ect_TE(i, j, k) = max(epse, ect_TE(i, j, k))
+ eps_TE(i, j, k) = max(epsd, eps_TE(i, j, k))
+ enddo
+ enddo
+ ! end do
+
+ ! +--Inversion Height
+ ! + ================
+
+ do i = 1, mx
+ WKxy1(i, j) = 0.05 * max(max(ect_TE(i, j, mmz1), &
+ ect_TE(i, j, mz)), ectmin)
+ WKxy2(i, j) = 1.
+ enddo
+
+ do k = 1, mz
+ do i = 1, mx
+ if(ect_TE(i, j, k) < WKxy1(i, j)) then
+ WKxy2(i, j) = min(mz1, k)
+ endif
+ enddo
+ enddo
+
+ do i = 1, mx
+ k = WKxy2(i, j)
+ if(ect_TE(i, j, k + 1) < ectmin) then
+ WKxy1(i, j) = gpmiDY(i, j, mz) * grvinv &
+ - sh(i, j)
+ else
+ dkect = ect_TE(i, j, k) - ect_TE(i, j, k + 1)
+ WKxy1(i, j) = (gpmiDY(i, j, k + 2) &
+ + (gpmiDY(i, j, k + 1) - gpmiDY(i, j, k + 2)) &
+ * (WKxy1(i, j) - ect_TE(i, j, k + 1)) &
+ / (sign(unun, dkect) &
+ * max(eps9, abs(dkect))) &
+ - gplvDY(i, j, mzz) &
+ ) * grvinv
+ endif
+ enddo
+
+ do i = 1, mx
+ zi__TE(i, j) = min(WKxy1(i, j), &
+ gpmiDY(i, j, 1) * grvinv - sh(i, j))
+ enddo
+
+ do i = 1, mx
+ zi__TE(i, j) = max(gpmiDY(i, j, mz) * grvinv - sh(i, j), &
+ zi__TE(i, j))
+ WKxy1(i, j) = 0.
+ WKxy2(i, j) = 0.
+#if(WR)
+ if(zi__TE(i, j) > 10000.) then
+ kect = k
+ kect = min(mz - 3, kect)
+ kect = max(5, kect)
+ write(6, 6001) i, j, k, kect,(ke, ke=kect + 3, kect - 4, -1) &
+ , zi__TE(i, j),(ect_TE(i, j, ke), ke=kect + 3, kect - 4, -1)
+6001 format('zi / TKE', 2(i6, i4), 8i10, /, d10.3, 18x, 8d10.3)
+ endif
+#endif
+ enddo
+ endif
+
+ ! +--TKE Production/Destruction by the Vertical Wind Shear
+ ! + =====================================================
+
+ ! do j=1,my
+ do k = kp1(1), mmz1
+ do i = 1, mx
+ WKxyz3(i, j, k) = uairDY(i, j, k) - uairDY(i, j, k + 1)
+ WKxyz4(i, j, k) = vairDY(i, j, k) - vairDY(i, j, k + 1)
+ enddo
+ enddo
+ ! end do
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz5(i, j, k) = &
+ gravit / (gplvDY(i, j, k) - gplvDY(i, j, k + 1))
+ ! +... 1/dz(k+1/2)
+ enddo
+ ! end do
+ enddo
+
+ do k = kp1(1), mmz1
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = &
+ TUkvm(i, j, k) * (WKxyz3(i, j, k) * WKxyz3(i, j, k) &
+ + WKxyz4(i, j, k) * WKxyz4(i, j, k)) &
+ * WKxyz5(i, j, k) * WKxyz5(i, j, k)
+ enddo
+ ! end do
+ enddo
+
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz1(i, j, mz) = 0.0
+ enddo
+ ! end do
+
+ ! +--Buoyancy
+ ! + ========
+
+ ! +--Reduced (Equivalent) Potential Temperature
+ ! + ------------------------------------------
+
+ ! do j=1,my
+ do i = 1, mx
+ WKxy5(i, j) = pktaDY(i, j, mzz) &
+ * exp(Lv_H2O * qvapSL(i, j) / (cp * TairSL(i, j)))
+ enddo
+ ! end do
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz2(i, j, k) = pktaDY(i, j, k) &
+ * exp(Lv_H2O * qvDY(i, j, k) / (cp * tairDY(i, j, k)))
+ enddo
+ ! end do
+ enddo
+
+ ! +--Buoyancy Coefficients
+ ! + ---------------------
+
+ do k = 1, mz
+ !c#HY do j=1,my
+ do i = 1, mx
+
+ hrel = 0.50 * (qvDY(i, j, k) / qvswDY(i, j, k) + &
+ qvDY(i, j, kp1(k)) / qvswDY(i, j, k))
+ WKxy3(i, j) = 0.50 * (qvswDY(i, j, k) + qvswDY(i, j, k + 1))
+ WKxy4(i, j) = 0.50 * (tairDY(i, j, k) + tairDY(i, j, kp1(k)))
+
+ sature = max(0., sign(1., hrel + eps12 - 1.))
+ base = WKxy3(i, j) * Lv_H2O / (RDryAi * WKxy4(i, j))
+
+ ! +--Vectorization of the unsaturated (H<1) and saturated cases (H=1.)
+ ! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ WKxy1(i, j) = &
+ ! H<1.
+ 1.-sature &
+ ! H=1.
+ + sature * (1.0 + base) &
+ / (1.0 + base * 0.605 * Lv_H2O / (cp * WKxy4(i, j)))
+ ! +... C_thq (Duynkerke & Driedonks 1987 JAS 44(1), Table 1 p.47)
+
+ WKxy2(i, j) = &
+ ! H<1.
+ (1.-sature) * (Lv_H2O / (cp * WKxy4(i, j)) &
+ - 0.605) &
+ ! H=1.
+ + sature
+ ! +... C_q_w (Duynkerke and Driedonks 1987)
+ ! + with (1-Ra/Rv)/(Ra/Rv) = 0.605 [Ra=287.J/kg/K;
+ ! + Rv=461.J/kg/K]
+
+ ! +--Unsaturated Case
+ ! + ~~~~~~~~~~~~~~~~
+ ! + if (hrel.lt.1.0) then
+ ! + WKxy1(i,j) = 1.0
+ ! + WKxy2(i,j) = Lv_H2O/(cp*WKxy4(i,j))
+ ! + . - 0.605
+
+ ! +--Saturated Case
+ ! + ~~~~~~~~~~~~~~~~
+ ! + else
+ ! + base = WKxy3(i,j)*Lv_H2O/(RDryAi*WKxy4(i,j))
+ ! + WKxy1(i,j) = (1.0+base)
+ ! + . /(1.0+base*0.605*Lv_H2O/(cp *WKxy4(i,j)))
+ ! + WKxy2(i,j) = 1.0
+ ! + end if
+
+ enddo
+ !c#HY end do
+
+ ! +--Buoyancy
+ ! + --------
+
+ if(k <= mmz1) then
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz3(i, j, k) = gravit &
+ * WKxyz5(i, j, k) * ((WKxyz2(i, j, k) - WKxyz2(i, j, k + 1)) * 2.0 &
+ / (WKxyz2(i, j, k) + WKxyz2(i, j, k + 1)) &
+ * WKxy1(i, j) &
+ - WKxy2(i, j) &
+ * (qvDY(i, j, k) - qvDY(i, j, kp1(k)) &
+ + qwHY(i, j, k) - qwHY(i, j, kp1(k)) &
+ + qrHY(i, j, k) - qrHY(i, j, kp1(k)) &
+ + qiHY(i, j, k) - qiHY(i, j, kp1(k)) &
+ + qsHY(i, j, k) - qsHY(i, j, kp1(k))) &
+ )
+ ! +... (g/theta) X(dtheta/dz) :
+ ! + Buoyancy Parameter beta X grad.vert.temp.pot. en k+1/2
+ enddo
+ ! end do
+
+ else
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz3(i, j, k) = gravit &
+ * WKxyz5(i, j, k) * ((WKxyz2(i, j, k) - WKxy5(i, j)) * 2.0 &
+ / (WKxyz2(i, j, k) + WKxy5(i, j)) &
+ * WKxy1(i, j) &
+ )
+ ! +... (g/theta) X(dtheta/dz) :
+ ! + Buoyancy Parameter beta X grad.vert.temp.pot. en k+1/2
+ enddo
+ ! end do
+ endif
+ enddo
+
+ ! +--Length Scales Parameters (Therry and Lacarrere 1983 Model)
+ ! + ========================
+
+ ! do j=1,my
+ do i = 1, mx
+ WKxy3(i, j) = 1.0 / zi__TE(i, j)
+
+ WKxy1(i, j) = 15.0 * WKxy3(i, j)
+ ! +... Ce1/hi
+ WKxy2(i, j) = 5.0 * WKxy3(i, j)
+ ! +... Ce1/hi
+ WKxy4(i, j) = 11.0 * WKxy3(i, j)
+ ! +... Ck2/hi
+ enddo
+ ! end do
+
+ ! do j=1,my
+ do i = 1, mx
+ sgnLMO = sign(unun, SLlmo(i, j))
+ absLMO = abs(SLlmo(i, j))
+ SLlmo(i, j) = sgnLMO * max(absLMO, eps12)
+ WKxy3(i, j) = -min(0., sgnLMO) &
+ / (1.0 - min(0., SLlmo(i, j)) / zi__TE(i, j))
+
+ ! +--Replacement of:
+ ! + if (SLlmo(i,j).lt.0.0) then
+ ! + SLlmo(i,j) = min(SLlmo(i,j),-eps12)
+ ! + WKxy3(i,j) = 1.0/(1.d0-SLlmo(i,j)/zi__TE(i,j))
+ ! + else
+ ! + SLlmo(i,j) = max(SLlmo(i,j), eps12)
+ ! + WKxy3(i,j) = 0.0
+ ! + end if
+ ! +... m2
+ ! end do
+ enddo
+
+ do k = kp1(1), mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz4(i, j, k) = sqrt(max(zero, WKxyz3(i, j, k)) / ect_TE(i, j, k))
+ ! +... 1/ls
+ enddo
+ ! end do
+ enddo
+
+ ! +--Dissipation Length
+ ! + ------------------
+
+ do k = kp1(1), mz
+ ! do j=1,my
+ do i = 1, mx
+ akz = voninv * gravit / (gpmiDY(i, j, k + 1) - gplvDY(i, j, mzz))
+ ! +... 1/kz(i,j,k+1/2)
+ ! +
+ alme = akz + WKxy1(i, j) &
+ - (akz + WKxy2(i, j)) * WKxy3(i, j) / (1.+5.0e-3 * zi__TE(i, j) * akz) &
+ + 1.5 * WKxyz4(i, j, k)
+ ! +... alme=1/Dissipation Length (Therry and Lacarrere, 1983 BLM 25 p.75)
+
+ ! +--Mixing Length
+ ! + -------------
+
+ almk = akz + WKxy1(i, j) &
+ - (akz + WKxy4(i, j)) * WKxy3(i, j) / (1.+2.5e-3 * zi__TE(i, j) * akz) &
+ + 3.0 * WKxyz4(i, j, k)
+ ! +... almk=1/Mixing Length (Therry and Lacarrere, 1983 BLM 25 p.78)
+
+ ! +--Contribution of Vertical Wind Shear + Buoyancy + Dissipation to TKE
+ ! + ===================================================================
+
+ pousse = -TUkvh(i, j, k) * WKxyz3(i, j, k)
+
+ epslme = eps_TE(i, j, k)
+#if(Kl)
+ epslme = 0.125 * alme * sqrt(ect_TE(i, j, k)) * ect_TE(i, j, k)
+#endif
+ ectnew = ect_TE(i, j, k) * &
+ (ect_TE(i, j, k) + dt_dif * (WKxyz1(i, j, k) + max(zero, pousse))) &
+ / (ect_TE(i, j, k) + dt_dif * (-min(zero, pousse) &
+ + epslme))
+ ! +... Numerical Scheme : cfr. E. Deleersnijder, 1992 (thesis) pp.59-61
+
+ ! +--Contribution of Vertical Wind Shear + Buoyancy to epsilon
+ ! + =========================================================
+
+#if(HR)
+ tranTE(i, j, k) = zero
+#endif
+ produc = WKxyz1(i, j, k) + max(pousse, zero) + max(tranTE(i, j, k), zero)
+
+#if(KI)
+ ! based on standard values of Kitada, 1987, BLM 41, p.220
+ produc = WKxyz1(i, j, k) + max(zero, pousse)
+#endif
+
+#if(BH)
+ ! based on values of Betts et Haroutunian, 1983
+ ! can be used by replacing strings `c #KI' (except the previous one)
+ ! and `c #BH' by blanks
+ ! (cfr. Kitada, 1987, BLM 41, p.220):
+ ! buoyancy > 0 (unstability) => (1-ce3) X buoyancy = 1.8 X buoyancy
+ ! buoyancy < 0 ( stability) => (1-ce3) X buoyancy =-1.15 X buoyancy
+ produc = WKxyz1(i, j, k) + max(zero, pousse) * 1.80 - min(zero, pousse) * 1.15
+#endif
+
+ factur = eps_TE(i, j, k) / ect_TE(i, j, k)
+ ! Numerical Scheme : cfr. E. Deleersnijder, 1992 (thesis) pp.59-61
+ eps_TE(i, j, k) = &
+ eps_TE(i, j, k) &
+ * (eps_TE(i, j, k) + dt_dif * factur * c1ep * produc) &
+ / (eps_TE(i, j, k) + dt_dif * factur * c2ep * eps_TE(i, j, k))
+
+#if(Kl)
+ eps_TE(i, j, k) = epslme
+#endif
+
+ ! +--New TKE Value
+ ! + =============
+
+ ect_TE(i, j, k) = ectnew
+
+ ! +--Dissipation Lengths Variables are Assigned for Output Purpose
+ ! + =============================================================
+
+ WKxyz1(i, j, k) = alme
+ WKxyz2(i, j, k) = almk
+ enddo
+ ! end do
+ enddo
+
+ ! +--OUTPUT Preparation
+ ! + ==================
+
+ ! if(( itexpe.gt.0.and.jmmMAR.eq.0.and.jssMAR.eq.0.and.
+ ! . ((IO_loc.ge.2.and. jhurGE .eq.0) .or.
+ ! . (IO_loc.ge.2.and.mod(jhurGE,3).eq.0) .or.
+ ! . (IO_loc.ge.3) ) ).or.
+ ! . IO_loc.ge.7 ) then
+ !
+ ! do i5 = 1,n5
+ ! aalme(i5,1) =0.0
+ ! aalmk(i5,1) =0.0
+ ! flott(i5,1) =0.0
+ ! do k = kp1(1),mz
+ ! if (WKxyz1(igrdIO(i5),jgrdIO(i5),k).gt.0.0) then
+ ! aalme(i5,k) = 1.0/WKxyz1(igrdIO(i5),jgrdIO(i5),k)
+ ! else
+ ! aalme(i5,k) = 0.0
+ ! end if
+ !C +... Le
+ ! if (WKxyz2(igrdIO(i5),jgrdIO(i5),k).gt.0.d0) then
+ ! aalmk(i5,k) = 1.0/WKxyz2(igrdIO(i5),jgrdIO(i5),k)
+ ! else
+ ! aalmk(i5,k) = 0.0
+ ! end if
+ !C +... Lk
+ ! flott(i5,k) = - WKxyz3(igrdIO(i5),jgrdIO(i5),k)
+ !C +... proportional to the buoyant force (e.g. Demoor, 1978, p.47)
+ ! end do
+ ! end do
+ ! end if
+
+ ! +--Lower Boundary Conditions
+ ! + =========================
+
+ do i = 1, mx
+ ! do j=1,my
+ WKxy1(i, j) = SLuus(i, j) * SLuus(i, j) ! -> TKE SBC
+ WKxy3(i, j) = (gplvDY(i, j, mz) - gplvDY(i, j, mzz)) * grvinv! z_SBL
+ !c#vL end do
+ enddo
+
+ do i = 1, mx
+ !c#vL do j=1,my
+ WKxy2(i, j) = WKxy1(i, j) * SLuus(i, j) ! -> e SBC
+ ect_TE(i, j, mz) = WKxy1(i, j) * sqrcmu ! TKE SBC
+
+ WKxy4(i, j) = WKxy3(i, j) / SLlmo(i, j) ! zeta
+ WKxy5(i, j) = max(0.0, sign(unun, SLlmo(i, j))) !
+ !c#vL end do
+ enddo
+
+ do i = 1, mx
+ !c#vL do j=1,my
+ eps_TE(i, j, mz) = WKxy2(i, j) &
+ ! phim Stab.
+ * ((WKxy5(i, j) * (1.+A_Turb * WKxy4(i, j)) &
+ ! phim Inst.
+ + (1.0 - WKxy5(i, j)) / (1.-20.*min(0., WKxy4(i, j)))) &
+ * voninv / WKxy3(i, j) &
+ - voninv / SLlmo(i, j))
+ ! +... Duynkerke, 1988, JAS (45), (19) p. 869
+
+#if(KI)
+ eps_TE(i, j, mz) = WKxy2(i, j) * voninv / WKxy3(i, j)
+#endif
+ !c#vL end do
+ enddo
+
+ ! +--When TKE Closure is Used, TKE is Modified near the Lower Boundary
+ ! + -----------------------------------------------------------------
+
+ do i = 1, mx
+ !c#vL do j=1,my
+#if(KC)
+ se = max(0., sign(unun, ect_TE(i, j, mmz2) - ect_TE(i, j, mmz1)))
+ ke = mmz1 - se
+ ! Schayes and Thunis, 1990, Contrib. 60 Inst.Astr.Geoph. p.8, 1.4.4.
+ ect_TE(i, j, mmz1) = ect_TE(i, j, ke)
+ eps_TE(i, j, mmz1) = eps_TE(i, j, ke)
+ ! ect_TE(i, j, mmz1) = ect_TE(i, j, mz)
+ ! eps_TE(i, j, mmz1) = eps_TE(i, j, mz)
+#endif
+
+ ! +--Upper Boundary Conditions
+ ! + =========================
+
+ ect_TE(i, j, 1) = ect_TE(i, j, kp1(1))
+#if(De)
+ ect_TE(i, j, 1) = ect_TE(i, j, mz) * rolvDY(i, j, mz) / rolvDY(i, j, 1)
+ ect_DI(i, j) = ect_TE(i, j, 1)
+#endif
+
+ eps_TE(i, j, 1) = eps_TE(i, j, kp1(1))
+#if(De)
+ eps_TE(i, j, 1) = eps_TE(i, j, mz) * rolvDY(i, j, mz) / rolvDY(i, j, 1)
+ eps_DI(i, j) = eps_TE(i, j, 1)
+#endif
+ ! +
+ ! end do
+ enddo
+
+ ! +--TKE-e Vertical Moving Average
+ ! + =============================
+
+ do k = mz__KA, mz1
+ !c#KA do j=1,my
+ do i = 1, mx
+ WKxyz7(i, j, k) = (dsigm1(kp1(k)) * ect_TE(i, j, kp1(k)) &
+ + dsigm1(k) * ect_TE(i, j, k) * 2. &
+ +dsigm1(km1(k)) * ect_TE(i, j, km1(k))) &
+ / (dsigm1(kp1(k)) &
+ + dsigm1(k) * 2. &
+ +dsigm1(km1(k)))
+ WKxyz8(i, j, k) = (dsigm1(kp1(k)) * eps_TE(i, j, kp1(k)) &
+ + dsigm1(k) * eps_TE(i, j, k) * 2. &
+ +dsigm1(km1(k)) * eps_TE(i, j, km1(k))) &
+ / (dsigm1(kp1(k)) &
+ + dsigm1(k) * 2. &
+ +dsigm1(km1(k)))
+ enddo
+ !c#KA end do
+ enddo
+
+ do k = mz__KA, mz1
+ !c#KA do j=1,my
+ do i = 1, mx
+ ect_TE(i, j, k) = WKxyz7(i, j, k)
+ eps_TE(i, j, k) = WKxyz8(i, j, k)
+ enddo
+ !c#KA end do
+ enddo
+
+ ! +--Verification: TKE must be Positive Definite
+ ! + ===========================================
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ ect_TE(i, j, k) = max(epse, ect_TE(i, j, k))
+ eps_TE(i, j, k) = max(epsd, eps_TE(i, j, k))
+ enddo
+ ! end do
+ enddo
+
+#if(HR)
+ ! +--Minimum Energy Dissipation Time
+ ! + ===============================
+ do i = 1, mx
+ edtnum = 0.0
+ edtden = 0.0
+ do k = 1, mz
+ edtnum = edtnum + ect_TE(i, j, k) * dsig_1(k)
+ edtden = edtden + eps_TE(i, j, k) * dsig_1(k)
+ enddo
+ if(edtden > 0.0) then
+ edt_TE(i, j) = betahr * edtnum / edtden
+ else
+ ! edt_TE set to an arbitrary small value
+ edt_TE(i, j) = 1.e-8
+ endif
+ enddo
+#endif
+
+ ! +--Turbulent Diffusion Coefficients
+ ! + ================================
+
+ if(locTKE > 0 .or. itexpe > 1) then
+
+ ! +--Richardson Number (contributors)
+ ! + -----------------
+
+ ! do j=1,my
+ do i = 1, mx
+ TU_Pra(i, j, mz) = 1.
+ enddo
+ ! end do
+
+ do k = kp1(1), mz1
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz6(i, j, k) = 0.0
+#if(RI)
+ WKxyz6(i, j, k) = 0.5 * (pktadY(i, j, k) - pktadY(i, j, k + 1)) * pcap &
+ / (tairDY(i, j, k) + tairDY(i, j, k + 1))
+ WKxyz7(i, j, k) = max((uairDY(i, j, k) - uairDY(i, j, k + 1))**2 &
+ + (vairDY(i, j, k) - vairDY(i, j, k + 1))**2, epsi)
+#endif
+ enddo
+ !c#vK end do
+ enddo
+
+ ! +--Richardson Number
+ ! + -----------------
+
+ do k = kp1(1), mz1
+ !c#vK do j=1,my
+ do i = 1, mx
+ WKxyz8(i, j, k) = 0.0
+#if(RI)
+ ! g * dz (k+1/2)
+ WKxyz8(i, j, k) = (gravit / WKxyz5(i, j, k)) &
+ ! d(theta)/T (k+1/2)
+ * WKxyz6(i, j, k) &
+ ! d|V|
+ / WKxyz7(i, j, k)
+#endif
+ enddo
+ !c#vK end do
+ enddo
+
+ ! +--Diffusion Coefficient for Heat
+ ! + ------------------------------
+
+ do k = kp1(1), mz
+ !c#vK do j=1,my
+ do i = 1, mx
+ TUkvh(i, j, k) = &
+ cmu * ect_TE(i, j, k) * ect_TE(i, j, k) / (eps_TE(i, j, k) &
+ )
+ ! nu_t =c_mu X ECT X ECT / eps
+#if(Kl)
+ TUkvh(i, j, k) = 0.50 * sqrt(ect_TE(i, j, k)) / WKxyz2(i, j, k)
+#endif
+
+ kz_max = vonkar * (gplvDY(i, j, k + 1) - gplvDY(i, j, mzz)) * grvinv
+ kz_mix = kz_max / (1.+kz_max * 0.1)
+ kz2mix = kz_mix * kz_mix
+ KvhMax(i, j, k) = max(5000., 100. &
+ *kz2mix * abs((ssvSL(i, j, k) - ssvSL(i, j, kp1(k))) &
+ * WKxyz5(i, j, k)))
+ TUkvh(i, j, k) = min(KvhMax(i, j, k), TUkvh(i, j, k))
+ TUkvh(i, j, k) = max(akmol, TUkvh(i, j, k))
+ enddo
+ !c#vK end do
+ enddo
+
+ ! +--Prandtl Number (Sukoriansky et al., 2005,
+ ! + -------------- BLM 117: 231-257, Eq.15, 19, 20 & Fig.2)
+
+ do k = kp1(1), mz1
+ !c#vK do j=1,my
+ do i = 1, mx
+#if(RI)
+ fac_Ri = 5.0 * max(WKxyz8(i, j, k), epsi)
+ vuzvun = 0.4 * (1.-(fac_Ri - 1./fac_Ri) / (fac_Ri + 1./fac_Ri)) + 0.2
+ fac_Ri = 4.2 * max(WKxyz8(i, j, k), epsi)
+ Kz_vun = 0.7 * (1.-(fac_Ri - 1./fac_Ri) / (fac_Ri + 1./fac_Ri))
+#endif
+ TU_Pra(i, j, k) = 1.
+#if(RI)
+ TU_Pra(i, j, k) = max(0., sign(1., TUkvh(i, j, k) - 0.20)) &
+ - min(0., sign(1., TUkvh(i, j, k) - 0.20)) &
+ * min(vuzvun / max(epsi, Kz_vun), 20.00)
+#endif
+ enddo
+ ! end do
+ enddo
+
+ ! +--Diffusion Coefficient for Momentum
+ ! + ----------------------------------
+
+ do k = kp1(1), mz
+ ! do j=1,my
+ do i = 1, mx
+ TUkvm(i, j, k) = TUkvh(i, j, k)
+ ! +... cfr Machiels, 1992, TFE (FSA/UCL) (3.21) p.21
+
+#if(Kl)
+ TUkvm(i, j, k) = 0.7 * TUkvh(i, j, k)
+#endif
+
+#if(RI)
+ TUkvm(i, j, k) = TU_Pra(i, j, k) * TUkvh(i, j, k)
+#endif
+ enddo
+ ! end do
+ enddo
+
+ endif
+
+#if(OB)
+ ! +--Lateral Boundary Conditions
+ ! + ===========================
+ if(openLB) then
+ if(mmx > 1) then
+ do k = 1, mz
+ do j = jp11, my1
+ ect_TE(1, j, k) = ect_TE(ip11, j, k)
+ ect_TE(mx, j, k) = ect_TE(mx1, j, k)
+ eps_TE(1, j, k) = eps_TE(ip11, j, k)
+ eps_TE(mx, j, k) = eps_TE(mx1, j, k)
+ TUkvm(1, j, k) = TUkvm(ip11, j, k)
+ TUkvm(mx, j, k) = TUkvm(mx1, j, k)
+ TUkvh(1, j, k) = TUkvh(ip11, j, k)
+ TUkvh(mx, j, k) = TUkvh(mx1, j, k)
+ enddo
+ enddo
+ endif
+ if(mmy > 1) then
+ do k = 1, mz
+ do i = ip11, mx1
+ ect_TE(i, 1, k) = ect_TE(i, jp11, k)
+ ect_TE(i, my, k) = ect_TE(i, my1, k)
+ eps_TE(i, 1, k) = eps_TE(i, jp11, k)
+ eps_TE(i, my, k) = eps_TE(i, my1, k)
+ TUkvm(i, 1, k) = TUkvm(i, jp11, k)
+ TUkvm(i, my, k) = TUkvm(i, my1, k)
+ TUkvh(i, 1, k) = TUkvh(i, jp11, k)
+ TUkvh(i, my, k) = TUkvh(i, my1, k)
+ enddo
+ enddo
+ endif
+ ! +... Lateral Boundary Values of Kzm and Kzh are used
+ ! + during the Initialisation Procedure in 1-D Zone
+ endif
+#endif
+
+ ! +--Hourly Output on Listing
+ ! + ========================
+
+ ! if(( itexpe.gt.0.and.jmmMAR.eq.0.and.jssMAR.eq.0.and.
+ ! . ((IO_loc.ge.2.and. jhurGE .eq.0) .or.
+ ! . (IO_loc.ge.2.and.mod(jhurGE,3).eq.0) .or.
+ ! . (IO_loc.ge.3) ) ).or.
+ ! . IO_loc.ge.7 ) then
+ !
+ ! do i5=1,n5
+ !
+ ! do k=1,mz
+ ! WKxza(i5,k) = 6.6d-1
+ ! . * (ect_TE(igrdIO(i5),jgrdIO(i5),k)**1.50)
+ ! . /(eps_TE(igrdIO(i5),jgrdIO(i5),k)
+ !C +... 0.066 = cmu(Duynkerke) * 2
+ !c #HR. +ect_TE(igrdIO(i5),jgrdIO(i5),k)
+ !c #HR. /edt_TE(igrdIO(i5),jgrdIO(i5))
+ ! . )
+ ! end do
+ !
+ ! write(4 ,61)explIO,igrdIO(i5),jgrdIO(i5),
+ ! . jdarGE,jhlrGE(igrdIO(i5),jgrdIO(i5)),
+ ! . jmmMAR,jssMAR,dt_dif,
+ ! . xxkm(igrdIO(i5)),
+ ! . SLlmo(igrdIO(i5),jgrdIO(i5)),
+ ! . zi__TE(igrdIO(i5),jgrdIO(i5))
+ !c #WE if (mod(jhaMAR,12).eq.0)
+ !c #WE. write(25,61)explIO,igrdIO(i5),jgrdIO(i5),
+ !c #WE. jdarGE,jhlrGE(igrdIO(i5),jgrdIO(i5)),
+ !c #WE. jmmMAR,jssMAR,dt_dif,
+ !c #WE. xxkm(igrdIO(i5)),
+ !c #WE. SLlmo(igrdIO(i5),jgrdIO(i5)),
+ !c #WE. zi__TE(igrdIO(i5),jgrdIO(i5))
+ ! 61 format(/,' EXP.',a3,' / Pt. (',i3,',',i3,')',
+ ! . ' / Turbulence Characteristics on',
+ ! . i5,'d',i2,'LT',i2,'m',i2,'s - dt=',f6.0,
+ ! . /,' ------------------------------------------',
+ ! . '-----------------------------------------',
+ ! . /,' x =',f5.0,'km',3x,'Lo =',e9.2,'m' ,3x,'zi =',f6.0,'m',
+ ! . /,' lev Altit. Temper. Pot.T. Wind_u Wind_v TKE ',
+ ! . ' epsilon Buoyancy Le Lk Le(e) Prandtl Kvm',
+ ! . ' Kvh Kvh MAX',
+ ! . /,' [m] [K] [K] [m/s] [m/s] [m2/s2] ',
+ ! . ' [m2/s2] [s-2] [m] [m] [m] [-] [m2/s]',
+ ! . ' [m2/s] [m2/s]')
+ ! write(4 ,62)(k,
+ ! . 0.1019*gplvDY(igrdIO(i5),jgrdIO(i5),k),
+ ! . tairDY(igrdIO(i5),jgrdIO(i5),k),
+ ! . 3.7300*pktaDY(igrdIO(i5),jgrdIO(i5),k),
+ ! . uairDY(igrdIO(i5),jgrdIO(i5),k),
+ ! . vairDY(igrdIO(i5),jgrdIO(i5),k),
+ ! . 0.1019*gpmiDY(igrdIO(i5),jgrdIO(i5),k+1),
+ ! . ect_TE(igrdIO(i5),jgrdIO(i5),k),
+ ! . eps_TE(igrdIO(i5),jgrdIO(i5),k),
+ ! . flott(i5,k) ,aalme(i5,k) ,aalmk(i5,k),WKxza(i5,k),
+ ! . TU_Pra(igrdIO(i5),jgrdIO(i5),k),
+ ! . TUkvm(igrdIO(i5),jgrdIO(i5),k),
+ ! . TUkvh(igrdIO(i5),jgrdIO(i5),k),
+ ! . KvhMax(igrdIO(i5),jgrdIO(i5),k),
+ ! . k=1,mz)
+ ! write(4 ,620)
+ ! 620 format(
+ ! . ' lev Altit. Temper. Pot.T. Wind_u Wind_v TKE ',
+ ! . ' epsilon Buoyancy Le Lk Le(e) Prandtl Kvm',
+ ! . ' Kvh Kvh MAX',
+ ! . /,' [m] [K] [K] [m/s] [m/s] [m2/s2] ',
+ ! . ' [m2/s2] [s-2] [m] [m] [m] [-] [m2/s]',
+ ! . ' [m2/s] [m2/s]',
+ ! . /,1x)
+ !c #WE if (mod(jhaMAR,12).eq.0) then
+ !c #WE m30=min(mz,30)
+ !c #WE write(25,62)(k,
+ !c #WE. 0.1019*gplvDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. tairDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. 3.7300*pktaDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. uairDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. vairDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. 0.1019*gpmiDY(igrdIO(i5),jgrdIO(i5),k+1),
+ !c #WE. ect_TE(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. eps_TE(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. flott(i5,k) ,aalme(i5,k) ,aalmk(i5,k),WKxza(i5,k),
+ !c #WE. TU_Pra(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. TUkvm(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. TUkvh(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. KvhMax(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. k=1,m30)
+ !c #WE write(25,64)
+ ! 64 format(/////)
+ !c #WE write(25,61)explIO,jhlrGE(igrdIO(i5),jgrdIO(i5)),
+ !c #WE. minuGE,jsecGE,dt_dif,
+ !c #WE. xxkm(igrdIO(i5)),
+ !c #WE. SLlmo(igrdIO(i5),jgrdIO(i5)),
+ !c #WE. zi__TE(igrdIO(i5),jgrdIO(i5))
+ !c #WE m31=min(mz,31)
+ !c #WE if (mz.ge.m31)
+ !c #WE. write(25,62)(k,
+ !c #WE. 0.1019*gplvDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. tairDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. 3.7300*pktaDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. uairDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. vairDY(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. 0.1019*gpmiDY(igrdIO(i5),jgrdIO(i5),k+1),
+ !c #WE. ect_TE(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. eps_TE(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. flott(i5,k) ,aalme(i5,k) ,aalmk(i5,k),WKxza(i5,k),
+ !c #WE. TU_Pra(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. TUkvm(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. TUkvh(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. KvhMax(igrdIO(i5),jgrdIO(i5),k),
+ !c #WE. k=m31,mz)
+ !c #WE end if
+ ! 62 format((i4,f8.0,2f8.2,2f7.2,
+ ! . /,4x,f8.0,30x,3e9.2,2f6.1,5f8.2))
+ ! write(4,63) SL_z0(igrdIO(i5),jgrdIO(i5),1),
+ ! . TairSL(igrdIO(i5),jgrdIO(i5)) ,
+ ! . SLuus(igrdIO(i5),jgrdIO(i5))
+ ! 63 format( 4x,f8.6, f8.2,8x,f8.3)
+ !
+ ! do k=1,mz
+ ! WKxza(i5,k) = 0.0
+ ! end do
+ !
+ ! end do
+ ! end if
+
+ ! +--Work Arrays Reset
+ ! + =================
+
+ ! do j=1,my
+ do i = 1, mx
+ WKxy1(i, j) = 0.0
+ WKxy2(i, j) = 0.0
+ WKxy3(i, j) = 0.0
+ WKxy4(i, j) = 0.0
+ WKxy5(i, j) = 0.0
+ enddo
+ ! end do
+
+ do k = 1, mz
+ ! do j=1,my
+ do i = 1, mx
+ WKxyz1(i, j, k) = 0.0
+ WKxyz2(i, j, k) = 0.0
+ WKxyz3(i, j, k) = 0.0
+ WKxyz4(i, j, k) = 0.0
+ WKxyz5(i, j, k) = 0.0
+ WKxyz6(i, j, k) = 0.0
+ WKxyz7(i, j, k) = 0.0
+ WKxyz8(i, j, k) = 0.0
+ tranTE(i, j, k) = 0.0
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+
+ locTKE = 1
+ ! +...locTKE: turn on TKE Evolution
+
+ return
+endsubroutine turtke_gen